perm filename STATS[S,AIL]49 blob
sn#248598 filedate 1976-11-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00050 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002
C00006 00003
C00007 00004 HISTORY
C00019 00005 For-Loop, Case Statement Variables
C00021 00006 Descriptions of For Loop Constructs, Bit Definitions
C00026 00007 FOR, DO, WHILE, NEEDNEXT Generators
C00030 00008
C00036 00009
C00039 00010 (continued), NEXT, DONE, CONTINUE
C00044 00011
C00048 00012
C00052 00013
C00059 00014
C00061 00015 ENTLAB, TRA -- generators for label placement, Go To statements
C00064 00016 TRAGO -- go-to-solver -- used also by RETURN code
C00067 00017
C00071 00018 CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators
C00074 00019
C00078 00020
C00079 00021 ↑CASE3: SOSL B,THISE THE TYPE OF EXPRESSION.
C00082 00022 PROCEDURE Structure Descriptions, Data Declarations
C00086 00023 PRDEC -- When Name is Seen
C00097 00024 ENDPR -- when params have been seen
C00106 00025 ENDRC -- MAIN RECORD CLASS EXEC
C00120 00026 PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.
C00124 00027
C00126 00028
C00134 00029
C00138 00030 RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
C00145 00031 NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
C00147 00032 TWPR1, TWPR2 -- Procedure Syntax Twiddlers
C00148 00033 RDYCAL -- Prepare to Call Procedure
C00153 00034 Describe CALARG
C00155 00035 CALARG -- Pass a Parameter
C00164 00036
C00166 00037 MPPARM: BINDING ITEMVAR PARAMETER
C00175 00038
C00180 00039 ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
C00184 00040
C00187 00041
C00190 00042 ISUCAL -- Call the Procedure, Mark Resultant Type, etc.
C00199 00043
C00204 00044 ARGFIX:
C00208 00045 RESULT -- Return (with or without value) from Procedure
C00213 00046
C00215 00047 DFVPV -- exec for default param values
C00216 00048 CLNSET
C00217 00049 DSCR Execs for PRINT and CPRINT statements.
C00223 00050 BEND PROCED
C00224 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000046 ⊗;
COMMENT ⊗
VERSION 17-1(38) 9-20-75 BY JFR #VD P.6 STR[1 STEP 1 UNTIL N] GAVE ILL MEM REF
VERSION 17-1(37) 2-1-75 BY JFR BAIL INTERFERRENCE WITH RECORDS, P.20
VERSION 17-1(36) 1-22-75 BY RHT BUG #TV# MAKE CLASS OF PNTVAR ARGS TO BUILTINS ANYCLASS
VERSION 17-1(35) 10-26-74 BY RHT BUG #TO# FUNNY TYPED BILTIN PROCEDURES
VERSION 17-1(34) 9-26-74 BY JFR INSERT TWO JSFIX'S WHICH WERE OMITTED ON P. 27
VERSION 17-1(33) 9-19-74 BY JFR INSTALL BAIL
VERSION 17-1(32) 8-3-74 BY RHT FEAT BN RECORD CLASSID IN ASCIZ
VERSION 17-1(31) 7-7-74 BY RHT MANY EDITS FOR RECGC
VERSION 17-1(30) 7-7-74
VERSION 17-1(29) 7-7-74
VERSION 17-1(28) 6-2-74 BY RHT MAKE EXTERNAL RECORD CLASSES WORK BETTER
VERSION 17-1(27) 5-29-74 BY RHT BUG #SH# NEEDED NOUSAC WHEN PUT OUT PDA WORD
VERSION 17-1(26) 5-28-74 BY RHT BUG #SD# NEEDED MUCH HAIR WHEN EXTERNAL PROC REDECLARED AS INT
VERSION 17-1(25) 4-12-74 BY RHT ADD RECORD CRUFT
VERSION 17-1(24) 4-12-74
VERSION 17-1(23) 4-12-74
VERSION 17-1(22) 4-12-74
VERSION 17-1(21) 4-12-74
VERSION 17-1(20) 1-31-74 BY RHT BUG #QX# MUST KEEP ADEPTH HONEST IN BUG FIX JK
VERSION 17-1(19) 1-11-74 BY JRL CMU CHANGE DON'T BARF AT EXTERNAL PROC DECS INSIDE SIMPLE PROC
VERSION 17-1(18) 1-11-74
VERSION 17-1(17) 1-11-74
VERSION 17-1(16) 1-8-74 BY RHT BUG #QH# FIX NEEDNEXT FOREACH PROBLEM
VERSION 17-1(15) 1-8-74
VERSION 17-1(14) 1-8-74
VERSION 17-1(13) 1-7-74 BY JRL BUG #QG# ALLOW MATCHING PROCEDURES WITH NO PARAMETERS
VERSION 17-1(12) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(11) 10-18-73 BY RHT FEAT %AE% PASSING TYPED ITEMVARS TO UNTYPED ONES
VERSION 17-1(10) 8-19-73 BY RHT BUG #NU# TRAGO NEEDED SPECIAL TEST FOR KILL SETS
VERSION 17-1(9) 8-19-73 BY RHT BUG #NT# NEED AN ALLSTO SOONER IN PRDEC
VERSION 17-1(8) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(7) 8-14-73 BY JRL FIX BAD FIX TO BUG NP
VERSION 17-1(6) 8-14-73
VERSION 17-1(5) 8-13-73 BY RHT ARRANGE FOR ITEMVAR PARAMS TO DEFAULT PROPERLY
VERSION 17-1(4) 8-12-73 BY JRL BUG #NP# DRYROT IN MATCHING PROCEDURE WITHOUT ? PARAMETERS
VERSION 17-1(3) 7-30-73 BY RHT BUG #NI# FIXUP FOR CONTINUE IN A DO... UNTIL...
VERSION 17-1(2) 7-27-73 BY RHT BUG #NH# ADEPTH PROBLEM FOR DEFAULTS
VERSION 17-1(1) 7-27-73
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(63) 7-9-73 BY JRL REMOVE ALL REFERENCES TO PATSW
VERSION 16-2(62) 6-29-73 BY RHT BUG #MY# FIX A TYPO
VERSION 16-2(61) 6-28-73 BY RHT BUGS #MX# & #MY#
VERSION 16-2(60) 6-28-73
VERSION 16-2(59) 6-28-73
VERSION 16-2(58) 6-28-73
VERSION 16-2(57) 6-28-73 BY JRL BUG #MA# CONCHK SHOULD SAVE FF OVER ITS CALL
VERSION 16-2(56) 6-27-73 BY RHT BUG #MV# NEEDED AN ACCESS BEFORE A PUT
VERSION 16-2(55) 5-15-73 BY JRL BUG #MJ# FOR CODE REMOPING WRONG SEMBLK
VERSION 16-2(54) 5-12-73 BY RHT BUG #MH# DRYROT IN EPNT FROM LOOP CODE
VERSION 16-2(53) 4-25-73 BY JRL BUG #ME# DRYROT IN ENDPR FOR FORWARD MATCHING PROCEDURE
VERSION 16-2(52) 4-25-73
VERSION 16-2(51) 3-22-73 BY RHT ADD DEFAULT PARAM VALUES
VERSION 16-2(50) 3-20-73 BY RHT ADD CODE FOR DEFAULT PARAM VALUES (ISUCAL)
VERSION 16-2(49) 3-13-73 BY RHT BUG #LQ# FWRD PROC PD SHOULD BE USED WHEN DECLARE THE PROC
VERSION 16-2(48) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(47) 2-26-73
VERSION 16-2(46) 2-14-73 BY JRL BUG #LL# PROTECTION OF AC CONTAINING UNBOUND IN MATCH PROC
VERSION 16-2(45) 2-12-73 BY JRL RETURN VAL OF MP NOW SAVED IN XX AREA
VERSION 16-2(44) 2-12-73 BY JRL BUG #LK# GET RID OF DRYROT AT BPOP AT END OF MATCH PROC
VERSION 16-2(43) 2-9-73 BY JRL MAKE AN ITEM PROCEDURE
VERSION 16-2(42) 2-9-73 BY JRL BUG #LJ# LEAP SHOULD STACK EVERYTHING BEFORE PROCEDURE CALL
VERSION 16-2(41) 2-9-73
VERSION 16-2(40) 2-9-73
VERSION 16-2(39) 2-7-73
VERSION 16-2(38) 2-5-73 BY JRL MOD MP'S FOR SPROUT
VERSION 16-2(37) 1-28-73 BY JRL ALLOW ?,BIND TO MPPARS OUTSIDE OF FOREACH
VERSION 16-2(36) 1-23-73 BY JRL REMOVE RESTRICTION ABOUT MP WITH SAME ACTUAL ? PAR TWICE
VERSION 16-2(35) 11-30-72 BY RHT MODIFY LOPSS TO CALL EPOLL
VERSION 16-2(34) 11-28-72 BY RHT INSERT EXEC FOR CLEANUP
VERSION 16-2(33) 11-13-72 BY RHT BUG #KD# RECURSIVE CORTMP IN ADRINS
VERSION 16-2(32) 11-11-72 BY RHT BUG #KB# BAD LPSA ENCLOBERMENT IN SYNTUP
VERSION 16-2(31) 10-21-72 BY JRL CHANGE FIX TO BUG JT
VERSION 16-2(30) 10-20-72 BY JRL BUG #JT# DON'T RELEASE SETS TO BE RETURNED BY FUNCTION
VERSION 16-2(29) 10-13-72 BY JRL SAV MP RETURN VAL OVER CALL TO STKUWD
VERSION 16-2(28) 10-3-72 BY JRL BUG #JK# SAVE AC 1 OVER CALLS TO RECLAIM VALUE SET
VERSION 16-2(27) 10-3-72 BY JRL MOVE DEF OF MPFLAG TO STATS
VERSION 16-2(26) 9-21-72 BY JRL MAKE SURE PROC FORMALS CAN BE ACCESSED
VERSION 16-2(25) 9-18-72 BY KVL TO ADD SPECIAL CHECK: REF PARAMS TO PROC ARGS OF PROCS.
VERSION 16-2(23) 9-8-72 BY JRL HANDLE ? LOCAL ITEMVARS AS PARAMETERS TO PROCS
VERSION 16-2(22) 8-23-72 BY RHT ONLY ALLOCATE PD SEMBLK IF NOT SIMPLE
VERSION 16-2(21) 8-19-72 BY JRL HANDLE ? PARAMS TO FOREACH
VERSION 16-2(20) 8-17-72 BY JRL ALTER ISUCAL TO HANDLE MATCHING PROCEDURES
VERSION 16-2(19) 7-26-72 BY RHT BUG #IS# NEEDNEXT WHILE LOOPS
VERSION 16-2(18) 7-18-72 BY RHT BUG #IP# SET VALUE PARAMS RELEASING
VERSION 16-2(17) 7-6-72 BY RHT BUG ##I#K# FIX DL LOADING BUG IN ISSUE
VERSION 16-2(16) 7-4-72 BY RHT MAKE DONE & CONTINUE STORE TEMPS BEFORE JUMPING
VERSION 16-2(15) 7-4-72 BY RHT DONE, NEXT, &CONTINUE
VERSION 16-2(14) 6-27-72 BY JRL BUG #HZ# ARRTRAN UPSET BY LSTBIT
VERSION 16-2(13) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(12) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(11) 6-14-72 BY JRL BUGS #HR#,#HS# STRING ITEMVAR PARAMS, AND PROCS.
VERSION 16-2(10) 6-14-72 BY DCS BUG #HT# SAVE REGS, RF, RESTORE RF ON F4 SUBROUTINE CALL
VERSION 16-2(9) 6-14-72 BY RHT PUT IN DONE OUT OF FOREACH IN SIMP PROC
VERSION 16-2(8) 6-13-72 BY DCS BUG #HQ# ALLOW RETURN OF STRING ITEMVARS
VERSION 16-2(7) 6-9-72 BY RHT MAKE DONE IN FOREACH CALL ON BEXIT
VERSION 16-2(6) 5-31-72 BY JRL FIX BUG #HM# DRYROT STRING PARAMS TO MESSAGE PROCEDURES
VERSION 16-2(5) 5-24-72 BY RHT MORE GO TO SOLVING
VERSION 16-2(4) 5-24-72 BY rht make trago look at pda of label
VERSION 16-2(3) 5-14-72 BY DCS BUG #HG# CONSTANT BOOLEANS DIDN'T WORK WITH /H
VERSION 16-2(2) 5-11-72 BY DCS BUG #GW# DON'T CALL AT COMPTIME IF WRONG #PARAMS
VERSION 16-2(1) 5-11-72 BY DCS BUG #GU# NEGAT PROBLEM WITH LIMIT OF FOR ... UNTIL
VERSION 15-6(10) 3-15-72 BY RHT FIX SIMPSW BUGS
VERSION 15-6(9) 3-10-72 BY RHT TO FIX NNEDNEXT WHILE LOOPS
VERSION 15-6(8) 3-6-72 BY RHT FIX SIMPLE BUG
VERSION 15-6(7) 3-6-72 BY RHT FIX SIMPLE PROC DECL BUG
VERSION 15-6(6) 3-6-72 BY RHT fix trago bug
VERSION 15-6(5) 3-1-72 BY DCS CALL RUNTIME FUNCS (CONST ARGS) AT COMPTIME
VERSION 15-2(4) 2-6-72 BY DCS BUG #GP# CHECK FORWARD FORMALS AGAINST THE REAL ONES
VERSION 15-2(3) 2-6-72 BY DCS BUG #FV# CASE N ... ["A"] BLEW
VERSION 15-2(2) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
COMMENT ⊗For-Loop, Case Statement Variables⊗
LSTON (STATS)
ZERODATA (LOOP/CASE STATEMENT VARIABLES)
;CASTAK -- PCNT values for each statement of a Case Statement or
; Expression are stored here via QPUSH (CASTAK is a Q-Descriptor).
; These are used for setting up the Case dispatch table for
; the statement
?CASTAK: 0
;FORLIS -- QSTACK Descriptor -- each entry is a saved FRBLK,
; put here when an inner Loop statement is started. See
; FRBLK for contents
?FORLIS: 0
;FRBLK -- Semantics of current FOR-type loop. See LOOP DSCRs
; for details of its contents
?FRBLK: 0
;FRDO -- class index from PARSER (via AC B), telling what kind of loop
?FRDO: 0
?FRTYPE: 0 ;LOOP TEMP VARIABLE
;NETTMP -- set if this is a NEEDNEXT loop -- coroutine-like code
; must be generated
?NETTMP: 0
ENDDATA
COMMENT ⊗ Descriptions of For Loop Constructs, Bit Definitions⊗
BEGIN LOOP
DSCR FORBG, WAIT, FRSTE, FRLOP, WHIL, DOLOOP, etc.
PRO FORBG WAIT FRSTE FRWHIL FRSTO FRLIST FRLOP WHIL DOLOOP
PRO LOPPS DOUNT DNEXT DDONE
DES These are the generators for any of the looping constructs.
When the construct is recognized at statement level, a block
is created and attached to the Semblk for the loop descriptor
(FORC, WHILC, FOREACH).
Appropriate routines are called to generate the loop header code.
The Single routine LOPPS is called at the end of the loop range.
It generates the return jump (and the ADD to the index variable,
if a FOR loop) and deletes the Semblk squandered for the interim
purposes of holding AC numbers, fixups, and the like.
The syntactic contexts of the calls to these routines are:
FOR IVB ← FORBG
SG E STEP WAIT
SG E UNTIL/WHILE WAIT
FORC LHS E STEP E UNTIL E SG FRSTE
FORC LHS E STEP E WHILE E SG FRWHIL
FORC LHS E SG FRSTO
FRLIST a for list seen
FRLOP a DO seen
WHILE BE DO WHIL
DO DOLOOP (at statement level)
DOL S UNTIL BE DO DOUNT
@LOOP S END LOPPS
NEXT DNEXT
DONE DDONE
⊗
DSCR -- Loop statement Semblk Format
RES The block that is appropriated for use holding things has the
following format:
$DATA xwd fixup to jump out,,address to jump back to.
$DATA2 good bits word for this looping statement.
$DATA3 fixup for any DONE's done.
$ACNO ac number for the FOR index
$DATA4 xwd pointer to step,, pointer to index.
$ADR fixup to start of statement (after that, the actual address)
$VAL level of forloop start,,0
$VAL2 pcnt for start of whole thing (used for coroutines).
Following are good bits stored in $DATA2 for my use in sorting out
the 10↑6 cases for FOR loops and friends:
⊗
BITDATA (FOR-LOOP SEMBLKS)
↑JSPDON←← 1 ;There was a push done at some point (corout or flist)
INCNST←← 2 ;Step element is constant.
INPOS ←← 4 ;Step element is positive.
INONE ←← 10 ;Step element is +- 1
DOUNB ←← 20 ;DO <s> UNTIL <be> ;
FSTAT ←← 40 ;FOR <id> ← <e> STEP <e> UNTIL <e>
LWHIL ←← 100 ;WHILE <be> DO
↑FRCHS ←← 200 ;FOREACH x,y ....
↑FLIST ←← 400 ;For lists in progress.
↑COROUT←← 1000 ;The guy is going to try to use the NEXT thing.
NOJMPS←← 2000 ;There are no jumps out or back!
NOJRST←← 4000 ;This is a thing without a jump out (i.e. ID←E,E do)
NOMARK←← 10000 ;Do not mark index for storing on exit -
; either an itemvar or it was a for step while
;which may clobber the index
; but will store it at any rate!
↑TMPUS←← 20000 ;A temp was used in a for statement. Do not allow
;loser to jump into the for loop.
IXVAR ←← 40000 ;INDEXED VAR FOR CONTROL VAR.
DONDON ←← 200000 ;A "DONE" WAS EXECUTED IN THIS LOOP, THE CONTROL
;VARIABLE MUST NOT BE ASSUMED CORRECT IN THE AC
; AT LOOP END (SEE MARKIT -- DCS -- 8/2/70)
ENDDATA
COMMENT ⊗ FOR, DO, WHILE, NEEDNEXT Generators⊗
↑FRCHT: SKIPA TBITS,[FRCHS] ;FOREACH LIST STARTER.
↑DOLOOP: ;HERE ON START OF "DO"
MOVEI TBITS,DOUNB
JRST RECORDIT ;GO MAKE A BLOCK.
↑WHIL1: ;START OF "WHILE"
SKIPA TBITS,[XWD 0,LWHIL]
↑FORBG: ;START OF "FOR"
MOVEI TBITS,FSTAT
RECORDIT: PUSHJ P,ALLSTO ;CLEAR THE BOARDS
HRRO A,FRBLK ;LEFT HALF NEGATIVE.
QPUSH (FORLIS) ;PUSH ON THE OLD FRBLK VALUE.
GETBLK ;AND GET A NEW ONE.
MOVE A,LEVEL ;RECORD THE CURRENT LEVEL.
HRLM A,$VAL(LPSA) ;AND SAVE.
AOS LEVEL ;SO THAT TRAGO WILL SEE US.
SKIPN NETTMP ;COROUTINE FEATURE ASKED FOR ?
JRST NOCORT ;NO COROUTINES TODAY.
TRO TBITS,COROUT!JSPDON ;MARK IT AS SO.
TRNE TBITS,LWHIL
JRST [
MOVE SP,LPSA ;FOR THE ROUTINE TO FOLLOW
PUSH P,TBITS
PUSH P,LPSA
PUSHJ P,GTJSPR ;KNOW WE HAVE TO GET A JSP REG
POP P,LPSA ;RESTORE LPSA
POP P,TBITS
JRST .+1]
MOVE A,PCNT ;CURRENT PC.
HRRM A,$VAL2(LPSA) ;AND FIXUP FOR THE JSP
TRNE TBITS,DOUNB ;COROUTINE DISALLOWED FORTHIS
ERR <NO COROUTINES HERE, PLEASE>,1
SETZM NETTMP ;FOR NEXT TIME. (PUN, PUN)
NOCORT: MOVE A,PCNT
MOVEM A,$DATA(LPSA) ;SAVE FOR START OF WHILE.
MOVEM TBITS,$DATA2(LPSA) ;STORE BITS.
MOVEM LPSA,FRBLK ;SAVE FOR INTERESTED PARTIES.
MOVEM LPSA,GENRIG ;FOR THE DOLOOP.
TRNE TBITS,FRCHS
TRNN TBITS,COROUT
POPJ P,
MOVE SP,LPSA
PUSHJ P,GTJSPR ;IF FOREACH COROUTINE, DO MOVEI NOW
MOVE LPSA,SP
POPJ P,
↑NEXTR: ;HE IS GOING TO ASK FOR NEXT.
SETOM NETTMP
POPJ P,
↑ENDFOR: PUSHJ P,INIT ;FINISH OUT FOREACH CODE.
JRST DOL1 ;NO JUMP BACK, PLEASE.
;;#NI# RHT 30-JULY-73 NEED A FIXUP FOR CONTINUES
↑CNFXP: MOVE SP,FRBLK ;
HLLZ B,$ACNO(SP) ;FIXUP TO THE TEST
JUMPE B,.+4 ;NO FIXUP
PUSHJ P,ALLSTO ;
HRR B,PCNT ;YES FIXUP
PUSHJ P,FBOUT ;
POPJ P,
;;#NI#
↑DOUNT: ;HERE ON DO S UNTIL....
PUSHJ P,STIF ;GO EVALUATE BOOLEAN.
; MOVE B,GENRIG ;RESULTANT FIXUP.
MOVE SP,FRBLK
HRR B,$DATA(SP)
;;#HG#2! 5-14-72 DCS (3-4) TEST ENTIRE LEFT HALF OR /H WON'T WORK
HLRE TEMP,B ;IF LH IS -1, WE HAVE
AOJE TEMP,DONON ; `DO S UNTIL TRUE', DO ONLY ONCE
PUSHJ P,FBOUT ;PUT OUT FIXUP.
JRST DONON ;FREE THE BLOCK, ETC.
↑WHIL: ;ALL DONE WITH A WHILE STATEMENT.
SETZM FRDO
PUSHJ P,STIF ;GO EVALUATE THE BOOLEAN EXPRESSION.
PUSHJ P,INIT ;GET GOOD BITS.
; MOVE B,GENRIG ;THE HORRID TRUTH.
HLLM B,$DATA(SP) ;FIXUP FOR JUMP OUT, LH -1 IF TRUE
JRST DOL ;GO MAKE CALLS IF NECESSARY.
↑LFOR: ;HERE FROM LEAP STUFF.
PUSHJ P,INIT ;GET SET UP, AND FILL UP "C";
HRRM PNT,$DATA4(SP) ;INDEX ... FOR WHAT IT IS WORTH.
PUSHJ P,ALLSTO ;STORE EVERYONE.
TRO C,NOMARK ;WE DO NOT MARK THE INDEX ON EXIT.
JRST FRS1 ;GO SEE ABOUT CALLS.
↑FRSTO: ;WE HAVE SEEN A <ID> ← E , OR <ID> ← <E> DO.
MOVEM B,FRDO ;B HAS INDEX FROM PARSER.
SOSL B,THISE ;SEE WHAT KIND OF EXPRESSION
JRST [JUMPN B,LPFRSTO ;LEAP
PUSHJ P,LEVBOL ;BOOLEAN
JRST .+1]
PUSHJ P,GETINDX ;PICK UP THE INDEX, START VALUE AND SAVE.
PUSHJ P,FORST ;GO DO THE STORE.
FRS1: TRNN C,FLIST ;IF LIST NOT GOING, THEN
SKIPE FRDO ;IF THIS IS THE LAST
JRST DOL1
TRO C,NOJMPS ;DO NOT EMIT ANY JUMPS.
JRST DOL1 ;GENERATE CALLS IF NECESSARY.
↑WAIT: ;HERE ON "STEP" OR "UNTIL/WHILE"
;;#VD# JFR 9-20-75
CAIGE B,4 ;4→TO, 5→FOR
SKIPN LENCNT ;NEQ 0 IMPLIES SUBSTRINGING
JRST .+2
ERR <Substringing uses TO or FOR.>,1,CPOPJ
;;#VD# ↑
JUMPE B,GETINDX ;FOR "STEP", JUST RECORD THE INDEX INFO.
JUMPL B,CPOPJ ;NOTHING DOING !
CAILE B,2 ;IF NOT UNTIL/WHILE
POPJ P, ;GO AWAY.
;DCS 8/16/70 CONVERT TYPE OF INCR
MOVE TEMP,FRBLK ;ALL INFO WE HAVE ABOUT LOOP SO FAR
;; \UR#11\ JRL GIVE REASONABLE ERROR MESSAGE FOR MISSING STEP AMOUNT
SKIPN $DATA4(TEMP) ;ANY SEMANTICS YET?
JRST [ ERR <MISSING STEP AMOUNT. WILL ASSUME 1.>,1
PUSHJ P,GETINDX ; STORE VAR AND START
MOVEI A,1 ; DEFAULT STEP IS 1
PUSHJ P,CREINT
HRRZM PNT,GENLEF+1
MOVE TEMP,FRBLK
JRST .+1]
;; \UR#11\ JRL - END OF STEP FIX
HRRZ TEMP,$DATA4(TEMP) ;SEMANTICS OF INDEX VARIABLE
HRR B,$TBITS(TEMP) ;TYPE
MOVE PNT,GENLEF+1 ;INCREMENT SEMANTICS
GENMOV (CONV,INSIST!GETD) ;MAKE SURE THEY MATCH
MOVEM PNT,GENLEF+1 ;FIXUP
;DCS 8/17/70
PUSHJ P,FORST ;GO HANDLE THE STORE.
MOVE PNT,GENLEF+1 ;INCREMENT.
PUSHJ P,CLEAR ;MAKE SURE OUT OF AC.
PUSHJ P,GETAD ;NOW GET SEMANTICS
TLNE SBITS,CORTMP ;IF A TEMP, THOUGH, BE SURE
TRO C,TMPUS ; NOT TO LET JUMPS COME INTO THE LOOP.
GENMOV (CONV,INSIST) ;B STILL LEFT OVER FROM FRSTO.
QPUSH (FORLIS,PNT)
TRZ C,INONE!INCNST!INPOS ;IN CASE WE COME THROUGH HERE THE SECOND
;TIME WHEN PUTTING OUT FOR LISTS.
TLNN TBITS,CNST ;IF STEP IS CONSTANT, THEN COMPUTE SOME THINGS.
JRST NOCVN
TRO C,INCNST ;ASSERT CONSTANT.
SKIPL $VAL(PNT) ;SEE ABOUT VALUE.
TRO C,INPOS ;ASSERT POSITIVE.
MOVM TEMP,$VAL(PNT) ;SEE ABOUT VALUE EQUAL TO 1.
CAIN TEMP,1
TRO C,INONE ;IT IS ONE!
NOCVN: ;PLACE TO JUMP BACK TO IN ORDER TO
;COMPUTE LIMIT.
HRRM TBITS2,$DATA(SP) ;SINCE STOREB WAS DONE, NOW AC INFO IS ASSUMED
HRLM PNT,$DATA4(SP) ;SAVE INCREMENT.
JRST FINOUT ;SAVE C AND EXIT.
STJSPR: PUSHJ P,INIT
TRNN C,COROUT ;IS IT A COROUTINE ????
POPJ P, ;NO !!!!!!!
HLRZ D,$ADR(SP) ;PICK UP AC NO
JUMPN D,HAVAC ;IF NOT FIRST TIME, THEN GET THE AC NO NOW
GTJSPR: PUSHJ P,GETAN0 ;GET THEE AC
PUSHJ P,MARKINT ;MAKE IT AN INTEGER TEMP
HRLM PNT,$VAL2(SP) ;SAVE THE TEMP
HRLM D,$ADR(SP) ;REMEMBER AC NUMBER
HRRZ PNT,SP ;
EMIT <MOVEI JSFIX> ;
POPJ P, ;
HAVAC: HLRZ PNT,$VAL2(SP) ;PICK UP THE TEMP
CAIN PNT,0 ;IS IT THERE
ERR <DRYROT AT WAIT>;NO
GENMOV (GET,GETD!SPAC!MRK)
HRLM PNT,$VAL2(SP) ;PUT IT AWAY -- NOW KNOW AC IS LOADED FOR
;COROUTINE CALL
POPJ P,
FORST: ;ROUTINE TO HANDLE THE STORES.
;;#IS# ! RHT 7-26-72 NEEDED TO BE SURE MOVEI AC,START IS DONE
PUSHJ P,STJSPR ;INIT, SET UP TEMP IF COROUT
HLRZ PNT,$DATA4(SP) ;EXPRESSION FOR START
HRRZ PNT2,$DATA4(SP) ;AND INDEX.
HLRZ D,$ADR(SP) ;PICK UP AC FOR COROUT OR JSP
TRNE C,COROUT!JSPDON ;IF WE HAVE ONE
HRROS ACKTAB(D) ;PROTECT IT
PUSHJ P,FORSTO ;SPECIAL GOSTO LIKE (A LA BOLSTO)
;THE POINT OF ALL THIS IS TO STORE ANY INCREMENT
;CALCULATIONS DONE. (I.E. TEMPS).
;BUT WE TRY TO KEEP START EXPR IN AC.
CAIE D,0 ;DID WE PROTECT SOMEONE?
HRRZS ACKTAB(D) ;YES -- WITHDRAW PROTECTION
PUSHJ P,GETAD2 ;GET SEMANTICS. OF INDEX
; TLNE SBITS2,INDXED!FIXARR
; TRO C,IXVAR ;INDEXED.
TLNN SBITS2,PTRAC ;IS IS INDXED (SHUDDER) ?
JRST .+3
HRRZ D,$ACNO(PNT2)
PUSHJ P,STORA ;GO STORE IT.
; HLRZ PNT,$DATA4(SP) ;STARTER VALUE IN PNT.
PUSHJ P,GETAD
HRRI FF,INSIST!INDX!POSIT!REM ;ALL THESE THINGS.
SKIPE D,$ACNO(SP) ;OLD DUSTY AC ?
TRO FF,SPAC ;YES -- AND MORE.
HRRZ B,TBITS2 ;TO FORCE TYPE CONVERSION TO INDEX TYPE.
GENMOV (GET) ;MAGIC
MOVE TBITS,PCNT ;REMEMBER PROGRAM COUNTER.
;(NOTE EXCHOP IN NEXT INSTR)
;;#MV# RHT USE TO BE A GENMOV PUT ONLY
GENMOV (ACCESS,EXCHIN) ;MARK FOR STORE -- ACTUALLY STORE IF THE
;THING WAS INDXED.
GENMOV (PUT,0) ;
;;#MV#
MOVEM D,$ACNO(SP) ;NEW AC# IF ANY.
MOVEM B,FRTYPE ;SAVE TYPE FOR THIS LIST.
POPJ P,
GETINDX: ;PICK UP INDEX AND STARTERD....
MOVE SP,FRBLK ;GET CURRENT BLOCK.
MOVE A,GENLEF+2 ;INDEX
HRL A,GENLEF+1 ;STARTER
MOVEM A,$DATA4(SP)
POPJ P, ;DONE
COMMENT ⊗ (continued), NEXT, DONE, CONTINUE⊗
↑FRWHILE: ;HERE ON FOR-STEP-WHILE
MOVEM B,FRDO ;INDEX FROM PARSER.
PUSHJ P,STIF ;EVALUATE THE BOOLEAN
; MOVE B,GENRIG ;FALSE FIXUP
PUSHJ P,INIT
HLLM B,$DATA(SP) ;FIXUP FOR JUMP OUT.
TRNE C,FLIST!COROUT ;ONLY IF STATEMENT BEING PUSHJ'ED TO, DO WE
PUSHJ P,INDXGET ;GET THE INDEX BACK IN THE RIGHT AC.
TRO C,NOMARK ;DO NOT MARK INDEX AC ON EXIT -- STIF STORED IT.
JRST DOL ;SEE ABOUT CALLING THE STATEMENT.
↑FRSTE: ;HERE ON FOR-STEP-UNTIL
MOVEM B,FRDO ;INDEX FROM PARSER.
PUSHJ P,INDXGET ;GET INDEX BACK IN THE AC.
MOVE B,FRTYPE
;;#GU# 5-11-72 DCS NEGAT BUG FIX
GETSEM (1) ;LIMIT
TLNN SBITS,NEGAT ;DO WE HAVE TO DO IT?
JRST LIMOK ; NO, GOOD
PUSH P,D
GENMOV (GET,PROTECT!INSIST!POSIT!UNPROTECT) ;GET RIGHT GUY
POP P,D
JRST NOWOK ;NOW IT'S OK
LIMOK: GENMOV (ACCESS,PROTECT!INSIST!UNPROTECT) ;BLESS IT
;;#MJ SAVE CONVERTED SEMBLK FOR LATER REMOP
MOVEM PNT,GENLEF+1
;;#GU#
NOWOK: TRNE C,INCNST ;IS INCREMENT CONSTANT ?
JRST FRCNST ;YES -- DO OTHER THINGS.
HRL C,D
PUSHJ P,GETAN0 ;WE WOULD OTHERWISE CLOBBER PROTECTED AC.
EMIT (MOVE USADDR!NORLC)
MOVSI A,(<SUB>) ;SUBTRACT INDEX-LIMIT
TRNN TBITS,INTEGR ;CORRECT ?
MOVSI A,(<FSB>)
PUSHJ P,EMITER ;AC NOW HAS INDEX - LIMIT.
MOVS PNT,$DATA4(SP) ;INCREMENT.
EMIT (SKIPL NOUSAC) ;SKIPL INCREMENT
HRL C,D ;GET AC #
EMIT (MOVNS NOUSAC!USADDR!NORLC)
MOVE A,[JUMPL NOADDR];THE JUMP OUT.
JRST REMTMP
FRCNST: MOVSS C ;BECAUSE WE NEED CONDITION BITS.
HRRI C,3 ;CODE FOR LEQ
TLNN C,INPOS ;ASSUMPTION CORRECT?
HRRI C,5 ;CODE FOR GEQ
MOVE A,[CAM USCOND] ;THE SUPER COMPARE INSTRUCTION.
PUSHJ P,EMITER
MOVSS C
MOVE A,[JRST NOUSAC!NOADDR]
REMTMP: MOVE TEMP,PCNT ;PROGRAM COUNTER OF THE JRST.
HRLM TEMP,$DATA(SP) ;SAVE IT.
PUSHJ P,EMITER
MOVE D,$ACNO(SP) ;GET BACK AC NUMBER
MOVE LPSA,GENLEF+1 ;LIMIT
PUSHJ P,REMOPL ;ALL DONE WITH IT.
DOL: TRZA C,NOJRST ;INDICATE THAT ADD'S ARE TO BE DONE.
DOL1: TRO C,NOJRST ;INDICATE NOT AN ADDITIVE FOR STATEMENT.
;NOW GENERATE CALLS TO STATEMENT IF NECESSARY.
TRNN C,COROUT!FLIST ;THESE ARE THE INTERESTING CASES.
JRST FINTO
TRNE C,COROUT ;COROUTINE ?
;;#QH# HACK TO FIX NEEDNEXT FOREACHES
PUSHJ P, [
TRNN C,FRCHS ;KLUGE SINCE FOREACH IS SPECIAL
JRST CRCAL ;NOT FOREACH, JUST COROUTINE CALL
PUSHJ P,CRCAL ;CALL IT.
HLRZ PNT,$VAL2(SP) ;
JUMPE PNT,CPOPJ ;NO TEMP CELL
HLRZ D,$ADR(SP)
MOVE A,[ MOVEM ]
JRST EMITER ]
;;#QH#
TRNN C,COROUT ;IF ONLY A FOR LIST, THEN
PUSHJ P,FLSCAL ;CALL IT.
ENDIT:
TRNE C,FRCHS ;FOREACH ?
JRST [PUSH P,C
LPCALL (FRLOOP)
POP P,C
JRST LSTTST]
TRNE C,NOJRST!NOJMPS ;IF NOT ADDING LOOPING STATEMENT,
JRST LSTTST ;GO SEE ABOUT FIXUPS AND THINGS.
TRNN C,FSTAT ;IF NOT FOR STATEMENT, THEN EMIT THE JRST
JRST [ ;BACK TO THE BEGINNING.
HRL C,$DATA(SP)
EMIT (JRST NOUSAC!USADDR)
JRST LSTTST]
ADDIT: HRRZ D,$ACNO(SP) ;MAY HAVE BEEN MANGLED BY COROUT STUFF
;NOW IS THE TIME TO PUT OUT THE ADDS AND THINGS.
TRNE C,INONE ;IS INCREMENT CONSTANT AND ONE ?
JRST ACCDOM ;YES
HLRZ PNT,$DATA4(SP) ;INCREMENT.
;;#MH# ! RHT 5-12-73 WAS GETAD BUT REALLY NEED ACCESS
GENMOV (ACCESS,GETD)
MOVSI A,(<ADD>)
TRNN TBITS,INTEGR ;IS THIS CORRECT ?
MOVSI A,(<FADR>)
PUSHJ P,EMITER
MOVE A,[JRST NOUSAC!USADDR]
JRST EJRT ;TO EMIT IT.
ACCDOM: MOVE A,[AOJA USADDR]
TRNN C,INPOS
HRLI A,(<SOJA>)
EJRT: HRL C,$DATA(SP) ;JUMP BACK.
PUSHJ P,EMITER ;EMIT IT.
LSTTST:
SKIPN FRDO ;WAS THIS THE LAST ?
JRST FLTEST ;YES -- GO SEE ABOUT FOR LISTS.
TRNE C,NOJRST ;JUMPS BACK?
JRST FINTO
HLLZ B,$DATA(SP) ;FIXUP FOR JUMP OUT.
HRRZS $DATA(SP) ;RESTART IT.
HRR B,PCNT
PUSHJ P,FBOUT
JRST FINTO ;FIXUP DONE -- GO AWAY.
FLTEST: TRNE C,NOJRST!COROUT ;IF ALREADY A JUMP OUT OR
TRNN C,FLIST!COROUT ;NO FOR LIST GOING AND NO COROUTINE
JRST STAT ; -- RECORD START OF STATEMENT.
HRRZ B,PCNT ;NONE -- NEED TO PUT IN JRST
TRNE C,COROUT ;COROUTINE??
JRST [
HLL B,$DATA(SP) ;FIXUP FOR THE JUMPS TO EXIT
TLNE B,-1 ;IF ANY
PUSHJ P,FBOUT ;
HRRZS $DATA(SP) ;START OVER
HLRZ D,$ADR(SP) ;JSP REGISTER
GENMOVE(GET,GETD!SPAC!POSIT);
HRLZ D,D
HRLI C,1
EMIT <JRST NOUSAC!NORLC!USX!USADDR>
JRST STAT
]
HRLM B,$DATA(SP) ;MAKE A FIXUP FOR JUMP OUT.
EMIT <JRST NOUSAC!NOADDR>
STAT: TRNN C,COROUT!JSPDON ;COROUTINE OR FOR LIST -- IE A JSP THING
JRST STAT.1 ;NO
HRLZ B,PCNT ;PICK UP PCNT
HLRM B,$DATA3(SP) ;REMEMBER WHERE
HLRZ PNT,$VAL2(SP) ;THIS TEMP
PUSHJ P,REMOP ;IS NOW KAPUT
HLRZ D,$ADR(SP) ;PICK UP THE AC
PUSHJ P,MARKINT ;NEW TEMP
HRLM PNT,$VAL2(SP) ;SAVE IT
TRNE C,COROUT ;IF COROUTINE
JRST FINTO ;THE "START" IS AT THE END (SO SKIP RETURN WORKS)
STAT.1: HRLZ B,$ADR(SP) ;SAY THAT THIS IS THE START
HRR B,PCNT ;THIS IS THE START OF STATEMENT.
TLNE B,-1
PUSHJ P,FBOUT
FINTO: SKIPE FRDO ;IF NOT LAST, THEN DON'T RECORD.
JRST FINOUT
MOVEM SP,GENRIG ;RECORD BEFORE GOING AWAY.
MOVEM SP,GENRIG+2 ;.....
FINOUT: MOVEM C,$DATA2(SP) ;SAVE C
POPJ P, ;AND EXIT.
FLSCAL: MOVE PNT,SP ;FOR LIST CALL.
TRO C,JSPDON
PUSH P,D ;DO I REALLY NEED TO?????????
HLRZ D,$ADR(PNT) ;
JUMPN D,EMTIT
PUSH P,PNT
PUSHJ P,GETAN0 ;
PUSHJ P,MARKINT
HRLM D,$ADR(SP);
HRLM PNT,$VAL2(SP);
POP P,PNT
EMTIT:
EMIT <JSP JSFIX>
POP P,D
POPJ P,
CRCAL:
HLRZ PNT,$VAL2(SP) ;TEMP SEMBLK
HLRZ D,$ADR(SP) ;AC NO
SKIPE TEMP,ACKTAB(D) ;WHAT IT THINKS IS THERE
CAIN PNT,(TEMP) ;IF NOTHING OR SAME THING
JRST TRISOK ;THEN DONT NEED TO
GENMOV (GET,GETD!SPAC!POSIT);GET IT THERE
TRISOK: EMIT <JSP INDRCT> ;CALL IT
POPJ P,
INIT: MOVE SP,FRBLK
SKIPE BNFG ;WANT A NAMED BLOCK??
PUSHJ P,FNLBK ;YES
MOVE C,$DATA2(SP) ;GOOD BITS WORD.
SKIPE FRDO ;FOR LIST (I.E. A COMMA)?
TRO C,FLIST ;RECORD THIS FOR ALL TIME.
MOVE D,$ACNO(SP) ;SET UP PRIVILEGED AC NUMBER.
POPJ P,
↑LOPPS: ;HERE AT END OF STATEMENT.
PUSHJ P,INIT
HLLZ B,$ACNO(SP) ;ANY "CONTINUE" FIXUPS DONE HERE
JUMPE B,DSTQQ
MOVE PNT,ACKTAB(D) ;IF (D) STILL HOLDS THE INDEX, THEN PROTECT
HRRZ PNT2,$DATA4(SP) ; WHAT I THINK INDEX IS
CAIN PNT2,(PNT)
HRROS ACKTAB(D)
PUSHJ P,ALLSTO
HRRZS ACKTAB(D)
HRR B,PCNT ;DO THE CONTINUE FIXUP NOW
PUSHJ P,FBOUT
DSTQQ: PUSHJ P,STORQQ ;STORE EVERYONET RELEVANT.
;BUT PERHAPS NOT THE INDEX.
SKIPLE POLINT ;DO WE WANT POLLS INSERTED?
PUSHJ P,EPOLL ;YES -- CALL TO SAVE ALL REGS
TRNE C,FLIST!COROUT ;ANY OF THESE THINGS ?
JRST HARDER ;YES -- ADDS ALREADY DONE.
PUSHJ P,ENDIT ;SEE ABOVE -- EMIT THE ADDS.
JRST MARKIT ;GO MARK THE AC, EMIT JUMP FIXUPS.
HARDER: TRNN C,COROUT ;COROUTINE??
JRST [HLRZ PNT,$VAL2(SP)
EMIT <JRST NOUSAC!INDRCT> ;NO
PUSHJ P,REMOP ;FLUSH IT
JRST MARKIT
]
PUSHJ P,CRCAL ;COROUTINE CALL
HRLZ B,$ADR(SP) ;THE "START" IS HERE
HRR B,PCNT
PUSHJ P,FBOUT
HRL C,$DATA3(SP) ;REAL START OF LOOP ADDRS
EMIT <JRST NOUSAC!USADDR>
HLRZ PNT,$VAL2(SP) ;WE DONT NEED HIM ANY MORE
PUSHJ P,REMOP
MARKIT:
JUMPOUT:
; TRNN C,IXVAR ;IF INDEXED VAR.
; JRST .+3
; PUSHJ P,REMOPA ;CLEAR OUT AC TABLE ENTRY.
; SETZM ACKTAB(D)
TRNE C,NOMARK ;IF HE REALLY DIDN'T WANT THE THING MARKED
PUSHJ P,CLEARA ;WIPE OUT THE AC.
TRNE C,DONDON ;DID SOMEBODY JUMP OUT VIA "DONE"?
PUSHJ P,CLEARA ;YES, WIPE OUT AC (DCS -- 8/2/70)
JMGO: TRNE C,NOJMPS ;IF NO JUMPS WERE DONE,
JRST ALDON ;THEN ALL DONE
HLL B,$DATA(SP) ;PLACE TO JUMP OUT.
HRR B,PCNT ;
;;#HG#2! 5-14-72 DCS (4-4) TEST ENTIRE LEFT HALF, OR /H WON'T WORK
HLRE TEMP,B ;If left half is -1,
AOJE TEMP,DONON ; there was no JRST FALSE (BE was TRUE)
PUSHJ P,FBOUT ;FIXUP TO JUMP OUT.
DONON: HLLZ B,$DATA3(SP) ;"DONE" FIXUP
JUMPE B,ALDON ;THESE HAVE FINISHED.
;;#TD# ! be sure dont do a done & leave loop with stuff inac
;; PUSHJ P,ALLSTO
;;NOTE: COULDN'T GET THE BUG TO HAPPEN
HRR B,PCNT
PUSHJ P,FBOUT
ALDON: FREBLK <SP> ;GOING,
SOS LEVEL
POPER: QPOP (FORLIS) ; GOING,
JUMPL A,DONER ;REMOPS DONE.
MOVE PNT,A
PUSHJ P,REMOP
JRST POPER
DONER:
HRRZM A,FRBLK ; GOING,
POPJ P, ; GONE.
↑DDONE: ;HERE ON "DONE" CONSTRUCT
SKIPN SP,FRBLK
ERR <"DONE" ILLEGAL OUTSIDE LOOP>,1,DDPOPJ
DONEXX: PUSHJ P,GOSTO ;IT IS SAME AS A GO TO
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP) ;LOOP LEVEL
MOVE C,$DATA2(SP) ;IF FOREACH STATEMENT, GO ONE MORE TO
TRNE C,FRCHS ;GET OUT OF THE FAKE BLOCK
SUBI SBITS,1
PUSHJ P,TRAGO
HRRZ C,$DATA3(SP) ;PROTECT RH FROM EXCH
HRL C,PCNT
EXCH C,$DATA3(SP) ;CHAIN FIXUPS FOR DONE.
MOVE TEMP,$DATA2(SP)
TRO TEMP,DONDON
TRZ TEMP,NOJMPS
MOVEM TEMP,$DATA2(SP)
EMIT (JRST NOUSAC!USADDR)
DDPOPJ: POPJ P,
↑DNEXT: ;HERE ON "NEXT" CONSTRUCT
PUSHJ P,STORQQ
NEXTXX: TRZ C,NOJMPS
HRRM C,$DATA2(SP)
TRNE C,COROUT ;ONLY ALLOW IF COROUTINE
JRST CTCOR ;GO CALL THE COROUTINE
ERR <USED NEXT WITHOUT PREPARATION>,1
POPJ P,
CTCOR: PUSHJ P,CRCAL ;CALL THE COROUTINE
PUSH P,PCNT
EMIT <JRST NOUSAC!NOADDR>
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP)
MOVE C,$DATA2(SP) ;IF FOREACH STATEMENT, GO ONE MORE TO
TRNE C,FRCHS ;GET OUT OF THE FAKE BLOCK
SUBI SBITS,1
PUSHJ P,TRAGO ;SOLVE THE GO TO
HLLZ C,$DATA(SP) ;JUMP OUT
HRR C,PCNT ;FIXUP
HRLM C,$DATA(SP) ;
EMIT <JRST NOUSAC!USADDR>
POP P,B
HRLZ B,B
HRR B,PCNT
PUSHJ P,FBOUT
HLRZ PNT,$VAL2(SP) ;TEMP FOR COROUT VAR
HRLZI SBITS,INAC ;MARK IT INAC
ORM SBITS,$SBITS(PNT)
HLRZ D,$ADR(SP) ;THE ACNO
HRRZM D,$ACNO(PNT)
HRRZM PNT,ACKTAB(D) ;SAY AC IS FULL OF IT
POPJ P,
STORQQ: PUSHJ P,QQW
SKIPA PNT,[0]
HRRZ PNT,ACKTAB(D)
HLRZ PNT2,$VAL2(SP) ;DONT WIPE THESE OUT -- JSP TEMP
JRST BOLSTO
↑CNTNUE:
SKIPN SP,FRBLK ;FETCH FOREACH BLOCK
ERR <"CONTINUE" ILLEGAL OUTSIDE LOOP">,1,CCPOPJ
CONTXX: PUSHJ P,GOSTO ;SAME AS A GO TO
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP) ;LOOP LEVEL
PUSHJ P,TRAGO ;SOLVE IT
HRL C,PCNT ;FIXUP
HRR C,$ACNO(SP) ;
EXCH C,$ACNO(SP) ;
EMIT <JRST NOUSAC!USADDR> ;JUMP TO LOOP END
CCPOPJ: POPJ P,
↑NEXTBN: ;NEXT -- WITH BLOCK NAME
SETOM BNFG ;SET A FLAG FOR INIT
PUSHJ P,STORQQ ;
SETZM BNFG ;
JRST NEXTXX ;
ZERODATA ()
BNFG: 0 ;FLAG TO TELL INIT TO FIND BLOCK NAME
ENDDATA
↑CONTBN: ;CONTINUE WITH BLOCK NAME
PUSHJ P,FNLBK
JRST CONTXX
↑DONEBN: ;DONE WITH BLOCK NAME
PUSHJ P,FNLBK
JRST DONEXX
FNLBK: ;FINDS THE NAMED LOOP BLOCK
;FIRST SEARCH FOR THE NAMED BLOCK
MOVE A,GENLEF
MOVE LPSA,$PNAME+1(A) ;THE REQUESTED NAME
MOVE TBITS2,PPSAV ;STACK POINTERS
MOVE SBITS2,GPSAV
LKNPE: HRRZ C,(TBITS2) ;PARSE ENTRY
CAME C,%NBEG ;A BEGIN???
JRST CHKILL ;NO
MOVE TEMP,(SBITS2) ;SEM ENTRY
CAME LPSA,$PNAME+1(TEMP) ;SAME???
JRST NXTBK ;NO
;HERE CHECK NEXT THING BACK TO SEE IF A LOOP
HRRZ C,-1(TBITS2) ;PICK UP
CAME C,%DOL ;
CAMN C,%WHILC
JRST OKBNM
CAME C,%ASSDO
CAMN C,%NFORC
JRST OKBNM
ERR <"DONE", "NEXT", OR "CONTINUE" TO A BLOCK NOT THE
BODY OF A LOOP >,1
EREXT: SKIPE BNFG ;FROM NEXT?
JRST [ POP P,(P) ;YES, TWO MORE LEVELS IN
POP P,(P)
JRST .+1 ]
POP P,(P)
POPJ P,
OKBNM: MOVE SP,-1(SBITS2) ;GET THE SEMANTICS INTO SP
POPJ P,
CHKILL: CAMN C,%NPDEC ;PROCEDURE DECL
JRST [ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" OUT OF PROCEDURE>,1
JRST EREXT ]
CAMN C,%NBLAT
JRST [ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" A BLOCK
THAT I CANT FIND>,1
JRST EREXT]
NXTBK: SOS TBITS2
SOJA SBITS2,LKNPE
STOREB: PUSHJ P,QQW ;DO IT.
JRST ALLSTO ;IF NOT FOR LOOP,STORE.
HRROS ACKTAB(D) ;PREPARE FOR STORES.
PUSHJ P,ALLSTO
HRRZS ACKTAB(D)
POPJ P,
INDXGET: TLOA FF,FFTEMP
QQW: TLZ FF,FFTEMP
PUSHJ P,INIT
TRNN C,FSTAT ;FOR STATEMENT?
POPJ P, ;NO GETTING TO BE DONE.
MOVE PNT,$DATA4(SP) ;INDEX.
PUSHJ P,GETAD
TRNE TBITS,STRING ;IF STRING,
POPJ P, ;ALL DONE.
PUSH P,SBITS ;SAVE.
GENMOV (GET,SPAC!POSIT) ;GET INDEX ......
POP P,TEMP ;RESTORE SBITS.
TLNN TEMP,INDXED!FIXARR ;IF THESE,
JRST NOIXX
TLZ TEMP,PTRAC!INAC ;....
MOVEM TEMP,$SBITS(PNT) ;RESTORE IT.
SETZM ACKTAB(D) ;AND....
NOIXX: TLNN FF,FFTEMP ;NOT IF JUST INDXGET.
AOS (P) ;SKIP RETURN.
POPJ P,
BEND LOOP
SUBTTL Land of Labels.
COMMENT ⊗ENTLAB, TRA -- generators for label placement, Go To statements⊗
BEGIN LABEL
DSCR ENTLAB, TRA
DES Execs for handling labels
For now, we are dealing with labels in the obvious way.
When in doubt, the poor loser cannot do the transfer he
requests. When we get more smarts, we can provide more features
(bugs?).
Semantic contexts:
ILB : ENTLAB
GOTO ILB TRA
SEE TRAGO DSCR, for the routine which does most of the work
(it is also used by RETURN, LOOP code)
⊗
↑ENTLAB: PUSHJ P,ALLSTO ;CLEAR THE BOARDS.
GETSEM (1)
MOVE LPSA,PNT
TRZN TBITS,FORWRD ;IT IS NO LONGER FORWARD.
ERR <LABEL ALREADY DEFINED:>,3
MOVEM TBITS,$TBITS(PNT)
HRLZ B,$ADR(PNT) ;FIXUP
JUMPE B,ENT1 ;HAS NOT BEEN USED YET.
HRR B,PCNT
PUSHJ P,FBOUT ;EMIT THE FIXUP.
ENT1: MOVE B,PCNT
HRRZM B,$ADR(PNT) ;THIS IS THE ADDRESS.
MOVE B,LEVEL ;THE LEVEL CURRENTLY AT.
PUSHJ P,TRAG1 ;SPECIAL -- TO GUARANTEE ACCESS.
TLNN FF,FFTEMP ;SUCCESSFUL ?
ERR <LABEL DEFINED AT LOWER LEVEL>,1
POPJ P, ;YES
↑TRA: PUSHJ P,GOSTO ;STORE EVERYONE -- HE MAY BE NEEDED
GETSEM (0) ;THE TARGET
MOVE B,LEVEL ;CURRENT LEVEL
HLRZ PNT2,$ACNO(PNT) ;PICK UP PDA SEMBK (MAY JUMP OUT OF PROC)
PUSHJ P,TRAGO ;DO THE WORK.
EMJRST: GETSEM (0) ;AGAIN
MOVE A,[JRST NOUSAC]
JRST EMITER ;ALL THROUGH.
COMMENT ⊗ TRAGO -- go-to-solver -- used also by RETURN code⊗
DSCR TRAGO, TRAG1 -- general complicated-jump solver
CAL PUSHJ from points within Label, Loop, RETURN code.
PAR AC B contains the LEVEL we are at.
AC SBITS contains the level we are trying to reach.
AC PNT2 POINTS AT TARGET PDA IF JUMP OUT OF PROC
DES TRAGO and TRAG1 search up the stack looking for syntactic
things that may need attention. If the level comparison indicates
putting out <ARRAY RELEASE> instructions, this is done. Note
that we disallow jumping out of a Procedure. Stack adjustment
many levels deep in recursion could be messy.
TRAG1 is called when a Label is finally defined to make sure of free
access from the level at which the label was "declared" to the level
at which it is finally defined. This prohibits jumping into certain
kinds of For Loops (those with stack problems), jumping into
Foreach statements, jumping into Blocks with Arrays dynamically
declared, etc.
⊗
ZERODATA(LOCAL NAMES FOR GO TO SOLVER)
BK: 0 ;SET TO SEMBLK FOR FIRST BLOCK OUT TO NEED EXITING
BL: 0 ;SET TO COUNT OF BLOCKS OUT TO GO
ENDDATA
BIT2DATA (BIT DEFS FOR GOOD GO TO SOLVING BITS)
ENDDATA
TRAG1: TLOA FF,FFTEMP
↑TRAGO: TLZ FF,FFTEMP ;B HAS LEVEL OF JUMP
LDB C,[POINT LLFLDL,SBITS,=35] ;C HAS LEVEL OF LABEL
SUB B,C ;B HAS NUMBER OF BLOCKS WE MUST GO UP.
JUMPE B,CPOPJ ;NO BLOCKS TO GO THROUGH.
SETZM BK ;ZERO PLACE KEEPERS
SETZM BL;
MOVE TBITS2,PPSAV
MOVE SBITS2,GPSAV ;PICK UP STACK POINTESS
TOK: HRRZ C,(TBITS2) ;PARSE ENTRY.
CAME C,%DOL ;DO S UNTIL BE.
CAMN C,%WHILC ;WHILE BE DO...
JRST .+3
CAME C,%ASSDO ;A FOREACH LOOP ?
CAMN C,%NFORC ;A FOR LOOP ????
JRST [
MOVE TEMP,(SBITS2) ;SEMANTICS
MOVE TEMP,$DATA2(TEMP); GOOD BITS
TRNN TEMP,COROUT!FLIST!FRCHS
JRST LGOUP ;NOTHING EXCITING
TLZE FF,FFTEMP ;LOSE IF COMING IN
POPJ P,
JRST LGOUP
]
TRYAL: CAMN C,%NBEG ;MIGHT IT BE A BLOCK
JRST DOBLK ;TREAT IT AS A BLOCK
CAME C,%BLKFRC ;FOREACH THING
JRST TRYUP ;NO
SKIPL PNT,(SBITS2) ;GET SEMANTICS FOR THIS
ERR <DRYROT AT TRAGO -- MISSING SEM FOR FOREACH>
SKIPN SIMPSW
JRST TGI ;GO SET UP FOR BEXIT
TLZE FF,FFTEMP ;SIMPLE PROC, CHECK GOING IN
POPJ P,
LPCALL (FRELS) ;RELEASE THE SO AND SO
JRST LGOUP ;GO ON UP
DOBLK:
SKIPL PNT,(SBITS2) ;GET SEM
JRST NXPRSU ;NONE
;;#NU# RHT 8-19-73 NEEDED BETTER CHECK FOR KILL SET
HRRZ TBITS,$ACNO(PNT) ;CHECK SPECIAL FOR KILL SET
JUMPN TBITS,TGI ;IF SO, MUST BEXIT
;;#NU#
MOVE TBITS,$VAL(PNT)
;;#SW#
NOREC <
TDNN TBITS,[XWD SBSCRP,SET] ;ALLOCATIONS?
>;NOREC
REC <
TDNN TBITS,[XWD SBSCRP,SET!PNTVAR] ;ALLOCATIONS??
;ALSO CHECK FOR RECORDS
>;REC
JRST LGOUP ;NO
TGI: TLZE FF,FFTEMP ;GOING IN?
POPJ P, ;LOSE
MRKUP: SKIPN BK ;IF FIRST BACK,SAY SO
MOVEM PNT,BK ;THIS IS THE FIRST
AOS BL ;INCR COUNT
LGOUP: SOJE B,XBKS ;IF UP, GO PUT OUT BEXIT
TRYUP: CAMN C,%NPDEC ;PROC?
JRST JOOPR ;YES, GO JUMP OUT
NXPRSU: SOS SBITS2
SOJA TBITS2,TOK
JOOPR: TLZE FF,FFTEMP ;
POPJ P, ;OK
PUSHJ P,XBKS ;GET OUT OF CURRENT BLOCKS
;; #MY# (1 OF 2) RHT BE SURE PD SEMBLK WILL APPLY
SKIPN PNT,PNT2 ;PICK UP PDA SEMBK
ERR <YOU CANNOT DO THIS GO TO>,1 ;
;; #MY# (1 OF 2) -- USED TO BE A SIMPLE MOVE PNT,PNT2
EMIT (<HRRZI LPSA,NOUSAC!JSFIX>) ;HRRZI LPSA,PDAOFLABEL
;;#MY# ! (2 OOF 2) RHT ALSO FIX A TYPO IN NEXT LINE
LDB C,[POINT LLFLDL,SBITS,=35] ;PICK UP LEX LEV OF LABEL
MOVSS C ;FOR EMITER
EMIT <HRLI LPSA,NOUSAC!USADDR!NORLC> ;HRLI LPSA,LL
XCALL <STKUWD> ;CALL THE STACK UNWINDER
POPJ P, ;ALL DONE
XBKS: SKIPN B,BK ;ANY TO EXIT
POPJ P, ;NO
HLLZ C,$SBITS(B)
HRR C,PCNT
HRLM C,$SBITS(B)
EMIT <HRRZI LPSA,NOUSAC!USADDR>
SOSG B,BL
JRST BEXCL
HRLZI C,(B)
EMIT <HRLI LPSA,NOUSAC!NORLC!USADDR> ; IF NEED, LOAD A COUNT
BEXCL: XCALL <BEXIT> ;EXIT THE BLOCK
POPJ P,
BEND LABEL
SUBTTL Case Statement Generators.
COMMENT ⊗CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators⊗
BEGIN CASE
DSCR CASSTR, CASEMT, CASEND, CASE1, etc.
PRO CASSTR CASEM1 CASEMT CASEN1 CASEND CASE1 CASE2 CASE3
DES EXECS for generating case statement code. The expression
generated is compared to the numcode. The generated code:
1. compares index into the statements to number of statements.
2. calls an error routine (run-time) if something is fishy.
3. does an indexed jrst to dispatch to the right statement.
The syntactic contexts are:
CASE E OF drarrow CASEX CASSTR
CASEX S drarrow CASEX CASEMT
CASEX [ E ] S ; drarrow CASEX CASEM1
CASEX S END drarrow S CASEMT CASEND
CASEX [ E ] S END drarrow S CASEM1 CASEN1
CASEX ( drarrow CASEE CASE1 ;EXPRESSION CASE STATEMENT
CASEE E , drarrow CASEE CASE2 ; "
CASEE E ) drarrow E CASE2, CASE3
⊗
COMMENT ⊗ The CASE SEMBLK has the following form:
%TLINK -- saved version of CASTAK (from prev level)
$PNAME,+1 -- standard
$TBITS -- standard in CASE expression
$SBITS -- level as usual
$ADR (both halves), $ACNO (lh) used for fixups
$VAL -- lowest case # seen,,highest seen
$VAL2 -- 0 if no S's seen, >0 if old style, <0 if new style
⊗
↑CASSTR: ;START OF CASE CONDITIONS
GETSEM (1) ;SEMANTICS OF THE EXPRESSION.
MOVE PNT2,PNT ;MAKE SURE BOTH ARE VALID
PUSHJ P,BOLSTO ;STORE ALL BUT INDEX
GENMOV (GET,INSIST!INDX!POSIT,INTEGR)
MOVE A,[SKIPL NOUSAC]
PUSHJ P,EMITER
PUSHJ P,REMOP ;ALL DONE.
GETBLK <GENRIG> ;FOR CASE STATEMENT TEMPORARIES.
MOVEW (<%TLINK(LPSA)>,CASTAK);SAVE OLD CASTAK
SETZM CASTAK ;AND START A NEW ONE
MOVE A,PCNT
HRLM A,$ADR(LPSA) ;FIXUP FOR THE COMPARE, WHICH FOLLOWS.
MOVE A,[CAIL NOADDR]
PUSHJ P,EMITER
XCALL <CSERR>
MOVE A,[JRST @USX+NOADDR+NOUSAC]
MOVSS D
PUSHJ P,EMITER
QPUSH (CASTAK,PCNT) ;SAVE ON GENERALIZED STACK THE STATEMENT
POPJ P,
↑CASE1: GETSEM (1) ;CASEX SEMANTICS.
PUSHJ P,GETAC ;RESERVE AN ACCUMULATOR.
MOVEM D,$ACNO(PNT) ;REMEMBER IT.
MOVEM PNT,GENRIG
POPJ P,
↑CASE2: MOVEM B,THISE
SOJL B,.+3
JUMPN B,LPCS2 ;..LEAP..
PUSHJ P,LEVBOL ;.....
MOVE SP,GENLEF+2 ;CASEE SEMANTICS.
MOVE D,$ACNO(SP) ;RESERVED AC.
GETSEM (1) ;THE EXPRESSION.
SKIPN B,$TBITS(SP) ;TYPE FOR THE EXPRESSION.
HRRZ B,TBITS
MOVEM B,$TBITS(SP) ;NOW IT HAS SOME IF NOT BEFORE.
HRRI FF,INSIST!REM ;FOR GENMOV -- REMOP SO ALLSTO WON'T SEE IT.
TRNE B,STRING ;SPECIAL FOR A STRING.
JRST [GENMOV (STACK)
MOVNI A,2
ADDM A,SDEPTH ;FIX UP THE STACK
JRST CAS22]
TRO FF,SPAC!POSIT
GENMOV (GET)
CAS22:
JRST CASEMT
;EMIT JRST TO END OF CASE STATEMENT
; CASE N OF BEGIN [E]S; [E]S; ... [E] S END;
↑CASEM1: GETSEM (5) ;SEMANTICS OF CASEX
SKIPLE TEMP,$VAL2(PNT);LEGAL TO EXPLICITLY NUMBER?
ERR <TOO LATE TO START NUMBERING CASES>,1 ;NO
JUMPL TEMP,NOTFST ;NOT FIRST
HRROS $VAL(PNT) ;SMALLEST SEEN IS VERY LARGE
SETOM $VAL2(PNT) ;LEGAL TO EXPLICITLY NUMBER
NOTFST: GETSM2 (3) ;SEMANTICS OF `E'
TLNN TBITS2,CNST ;MUST BE CONSTANT
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
;;#FV# DCS 2-6-72 (1-1) CASE N OF BEGIN ["A"] DIDN'T WORK
GENMOV (CONV,EXCHIN!INSIST!EXCHOUT,INTEGR);A REASONABLE CONST.
;;#FV# (1-1)
SKIPGE TBITS2,$VAL(PNT2);NON-NEGATIVE?
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
QPOP (CASTAK) ;GET PTR 1ST WD PREV STATEMENT
HRL A,TBITS2 ;CASE #
QPUSH (CASTAK) ;NOW CORRECT ENTRY
JRST CASSDO ;CONTINUE
;CASE N OF BEGIN S; S; S; S; ... S END;
↑CASEMT:GETSEM (2)
SKIPGE $VAL2(PNT) ;LEGAL TO IMPLICITLY NUMBER?
ERR <EXPLICIT CASE NUMBER REQUIRED>,1
HRRZM PNT,$VAL2(PNT) ;GT 0 MEANS IMPLICIT NUMBERING
AOS TBITS2,$VAL(PNT);NUMBER SEEN
CASSDO: PUSHJ P,ALLSTO ;STORE ALL
MOVE A,[JRST NOUSAC+JSFIX]
PUSHJ P,EMITER
HRL A,TBITS2 ;GET CURRENT NUMBER
HRR A,PCNT ;AND PC
QPUSH (CASTAK) ;SAVE
CASDO2: HLRZ TEMP,$VAL(PNT);LOWEST SEEN YET
CAMGE TBITS2,TEMP ;THIS ONE LOWER?
HRLM TBITS2,$VAL(PNT);YES, THEN NO
HRRZ TEMP,$VAL(PNT)
CAMLE TBITS2,TEMP ;SAME FOR UPPER
HRRM TBITS2,$VAL(PNT)
POPJ P,
↑CASEMM:GETSEM (4) ;SEMANTICS OF CASEX
SKIPLE TEMP,$VAL2(PNT)
ERR <TOO LATE TO START NUMBERING CASES>,1 ;ERR
JUMPL TEMP,NOTFS2
HRROS $VAL(PNT) ;SEE CASEM1
SETOM $VAL2(PNT)
NOTFS2: GETSM2 (2)
TLNN TBITS2,CNST
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
GENMOV(CONV,EXCHIN!INSIST!EXCHOUT,INTEGR)
SKIPGE TBITS2,$VAL(PNT2)
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
QPOP (CASTAK)
HRL A,TBITS2
QPUSH (CASTAK)
QPUSH (CASTAK)
JRST CASDO2
↑CASE3: SOSL B,THISE ;THE TYPE OF EXPRESSION.
JRST [JUMPN B,LPCS3
PUSHJ P,LEVBOL
JRST .+1]
MOVE PNT,GENLEF+2 ;CASEE
MOVE D,$ACNO(PNT) ;RESERVED AC.
GENMOV (MARK,GETD) ;MAKE A TEMP (TBITS IS MAGICALLY SET UP
MOVEM PNT,GENRIG ;MARK THE EXPRESSION.
MOVEI A,2
TRNE TBITS,STRING
ADDM A,SDEPTH ;UNDO THE DAMAGE
;FALL THROUGH TO EMIT JRSTS.
↑CASEND:GETSEM (2) ;CASEX SEMANTICS
JRST CASENS
↑CASEN1: GETSEM (5) ;CASEX SEMANTICS.
CASENS: HRRZ B,$VAL(PNT) ;COUNT OF STATEMENTS.
SKIPG $VAL2(PNT) ;RANDOM NUMBERING?
ADDI B,1 ;YES, BE COMPATIBLE (CAIL)
MOVE TBITS2,PCNT ;CURRENT PC
ADDI TBITS2,(B) ; + # STATEMENTS IS OUT ADDR
HLL B,$ADR(PNT) ;FIXUP FOR THE CAIL
PUSHJ P,FIXOUT ;DO NOT RELOCATE THE FIXUP.
ADD B,[XWD 2,0]
HRR B,PCNT
PUSHJ P,FBOUT ;FIXUP FOR INDEXED JRST.
HRRZS $VAL(PNT) ;XWD 0,LAST STMT
SKIPL $VAL2(PNT) ;RANDOM NUMBERING?
SOS $VAL(PNT) ; NO, ONE TOO BIG
MOVEI LPSA,CASTAK ;SET FOR QSTACK OPS
TDZA C,C ;C←0, ALWAYS QBEG ONCE
CELUP: SKIPGE $VAL2(PNT) ;EXPLICIT NUMBERING
PUSHJ P,BBEG ; YES, ALWAYS START AT HEAD
JUMPE B,CLD ;NO QSTACK
CAMLE C,$VAL(PNT) ;DONE?
JRST CLD ; YES
CEILUP: HRRZ A,TBITS2 ;IN CASE NO SUCH ENTRY
PUSHJ P,QTAK ;GET NEXT
JRST RNDM ; NO SUCH NUMBER, USE OUT ADDR
HLRZ TEMP,A ;CASE # THIS STATEMENT
CAME C,TEMP ;THERE YET?
JRST CEILUP ; NOPE
HRRZS A ;YEP, THIS ADDR
RNDM: TLO FF,RELOC
PUSHJ P,CODOUT ;WRITE DISPATCH ADDR
AOJA C,CELUP ;GET NEXT
CLD: QFLUSH (CASTAK) ;DELETE STACK
MOVEW (CASTAK,<%TLINK(PNT)>);RESTORE OLD ONE
HRR B,PCNT ;FIXUP OUT JUMPS
HRL B,$ADR(PNT)
MOVE LPSA,PNT
PUSHJ P,URGSTR ;IF CASE STATEMENT, NAMED
FREBLK (PNT)
JRST FBOUT ;AND RELEASE CASEX SEMBLK
BEND CASE
SUBTTL Procedure Declarations.
BEGIN PROCED
COMMENT ⊗PROCEDURE Structure Descriptions, Data Declarations⊗
DSCR PRDEC -- name and type known, prepare for proc
PRO PRDEC
DES
PD0: PDEC @I ( drarrow PDEC EXEC PRDEC CLRSET SCAN ¬DS1
PDEC @I ; drarrow PDEC EXEC PRDEC ENDDEC SCAN ¬DS1
Procedure declaration. This routine has three parts:
1. Save status -- Temp ring, TTOP, TPROC
2. Initialize status -- VARB, ADEPTH, SDEPTH, FORMFX stack, TPROC, TTOP.
Down a text level, set FF bits for parameter scan
3. Output necessary code for beginning of procedure (if not FORWRD).
An ENTER has already been done for the symbol (semantics in NEWSYM).
SEMBLK descriptions for procedure Semantics
%TLINK pnts to 2d Semblk for proc ,,%TBUCK standard
$PNAME standard
$TBITS standard
$SBITS standard -- RTNDON on means a RETURN was seen in this proc
$ADR <note1> ,,<note2>
$ACNO <note3> ,,<note4>
%RVARB, %RSTR standard
2d Semblk
%TLINK -- pnts to 1st formal Semblk ,,%STEMP pnts to saved TTEMP list (%TBUCK)
%SAVET ptr to old TTOP ,, ptr old TPROC ($PNAME)
$NPRMS # arith params+1 ,, # string params * 2 ($PNAME+1)
$BLKLP BLKLIM qstack dscriptr saved at PRDEC ($TBITS)
$SBITS <note5>
$VAL -1 if TOPLEV on at PRDEC
$VAL2 DDT level of this procedure
<note1> fixup chain of jumps past SUB/PUSH code in string exit sequences
(for non-recursive RETURNs which return non-temp Strings).
<note2> fixup until entry addr known (delayed to PRUP for recursive procs),
then addr of procedure entry sequence
<note3> address of first word of proecedure text (for finding text, adjusting AOS)
<note4> fixup chain of jumps to procedure exit sequence (incl SUB/PUSH for Str)
<note5> address of JRST around 1st procedure in nest
⊗
ZERODATA (PROCEDURE CODE VARIABLES)
;FTRPRM -- QSTACK Descriptor -- holds Semantics of actual
; parameters as they are developed for FORTRAN calls.
; These are QTAKed back off after the JSA is generated
?FTRPRM: 0
;FORMFX -- formal fixups QSTACK Descriptor -- see TOTAL for
; definition, description
;MESFLG -- on in Procedure call code if call is a MESSAGE
; call
?MESFLG: 0
;TBSAVE -- Temp cell used to save tbits during call to DYNAMAK(ADRINS);
;
?TBSAVE: 0
;MPFLAG -- Flag to FTRADR to tell that we really want the type bits
;in the left half of the adcon
↑↑MPFLAG:0
;MPQCNT - number of matching procedure params seen so far
?MPQCNT: 0
;MPVARS - qstack of ? params seen thus far
?MPVARS: 0
ENDDATA
COMMENT ⊗ PRDEC -- When Name is Seen⊗
; 1 -- SAVE STATUS
;;#GP# DCS 2-6-72 (3-4) CHECK FORWARD FORMALS AGAINST REAL ONES
↑PRDEC: SETOM OLDPRM ;NO SAVED FORMAL DECLS YET
;;#NT# ! RHT 8-19-73 REALLY NEED AN ALLSTO HERE, WHILE STILL HAVE OLD TEMPS
PUSHJ P,ALLSTO
MOVEI A,PROCED ;BITS FOR PROCEDURE
IOR A,BITS
TRNE A,ITEM
TRC A,ITEM!ITMVAR ;ITEM PROCEDURES REALLY ITEMVAR PROCS
MOVEM A,BITS
PUSHJ P,ENTID ;ENTER THE SYMBOL
;;#GP# (3) ALSO SET UP OLDPRM IN ENTERS
MOVE PNT,TPROC ;PNT CURRENT PROC SEMANTICS.
LEFT PNT,%TLINK,LPSERR ;LPSA to pnt to 2D TPROC BLOCK
RGC <
HRR TEMP,RCTEMP
HRLM TEMP,%RVARB(LPSA) ;SAVE RCTEMP LIST
>;RGC
HRR TEMP,TTEMP
HRRM TEMP,%STEMP(LPSA) ;SAVE CURRENT TEMP RING.
PUSH P,LPSA ;SAVE ptr to 2D BLOCK OF SURROUNDING PROC
MOVE PNT2,NEWSYM ;NEW SYMBOL (PROCEDURE NAME)
LEFT PNT2,%TLINK,LPSERR ;LPSA ptr to 2D BLOCK
HRL PNT,TTOP ;TTOP,TPROC SAVED HERE
MOVEM PNT,%SAVET(LPSA)
TLZE FF,TOPLEV ;NO LONGER AT TOP LEVEL,
SETOM $VAL(LPSA) ; BUT SAVE PREVIOUS STATUS
MOVEW (<$BLKLP(LPSA)>,BLKIDX) ;SAVE CURRENT BLKIDX
SETZM BLKIDX ;CLEAR NEW ONE
AOS TEMP,NMLVL ;UPDATE DDT LEVEL
SETZM $SBITS(LPSA) ;JRST AROUND PROCS ADDR
HRRZM TEMP,$VAL2(LPSA)
; 2 -- INITIALIZE STATUS FOR THIS PROCEDURE
; ***** BUG TRAP
SKIPN ADEPTH ;THESE SHOULD BE ZERO HERE
SKIPE SDEPTH
ERR <DRYROT -- ADEPTH OR SDEPTH >,1
FOR II IN (VARB,APARNO,SPARNO,ADEPTH,SDEPTH,TTEMP) <
SETZM II>
RGC <
SETZM RCTEMP
>;RGC
COMMENT ⊗
AT THIS POINT YOU MAY WANT TO SAVE OLD DISPLAY LIST
⊗
MOVE A,$SBITS(PNT2) ;NEED TO ZERO OUT THE DL FLD
TRZ A,DLFLDM ;ZERO IT
MOVEM A,$SBITS(PNT2) ;PUT IT BACK
SETOM RECSW ;ASSUME RECURSIVE -- IF WRONG WILL FIX BELOW
MOVE TBITS2,$TBITS(PNT2) ;BITS FOR THIS PROCEDURE
MOVEI A,0 ;ASSUME A RECURSIVE PROCEDURE
TLNN TBITS2,RECURS
MOVNI A,1 ;NON-RECURSIVE -- INDICATE NO FORMAL FIXUPS
XORM A,RECSW ;THIS WILL SET RECSW TO ALL 0 IF NOT RECSV
;; #MX# (1 OF 1) RHT CHECK FOR NON SIMP INSIDE SIMP
;;%##% ALSO DO NOT BARF AT EXTERNAL OR FORTRAN
TDNN TBITS2,[ XWD SIMPLE+EXTRNL,FORTRAN]
SKIPN SIMPSW
JRST .+2
ERR <YOU HAVE DECLARED A NON-SIMPLE PROCEDURE INSIDE
A SIMPLE PROCEDURE. WE MAKE NO PROMISSES... >,1
;; #MX#
SETOM SIMPSW ;ASSUME SIMPLE
NOBAIL<
TLNE TBITS2,SIMPLE ;IS IT REALLY
JRST GOTPD ;YES
SETZM SIMPSW ;NOT SIMPLE
>;NOBAIL
BAIL<
TLNN TBITS2,SIMPLE ;IS IT REALLY
SETZM SIMPSW ;NO
MOVE TEMP,BAILON
TLNE TBITS2,SIMPLE ;SKIP IF NOT SIMPLE
TRNE TEMP,BBPDSM ;SKIP IF SIMPLE PROCS DONT GET PDS
JRST .+2 ;PROC WILL GET A PD
JRST GOTPD ;SIMPLE PROC AND NO PD
>;BAIL
;;#LQ# 2! RHT IF FWRD PROC HAD A PD, THEN KEEP IT
HRRZ LPSA,$VAL(PNT2) ;HAD A PD?
JUMPN LPSA,GOTPD ;DONT GET ANOTHER
;;#LQ#
GETBLK ;FOR PROC DESC STUFF
HRRM LPSA,$VAL(PNT2) ;RECORD IT
GOTPD:
BAIL<
MOVE TEMP,BCORDN ;COORDINATE NUMBER AT PRDEC
HRLM TEMP,$VAL(LPSA) ;PLACE INTO PD SEMBLK
>;BAIL
QPUSH (FORMFX) ;SAVE MARKER
MOVEM PNT2,TPROC ;LET EVERYONE KNOW
MOVEM PNT2,TTOP ; WHO HAS A RIGHT TO KNOW WHERE
MOVEM PNT2,GENRIG ; THIS PROCEDURE IS
;5-12-72
; MOVEM PNT2,GENRIG+1 ; (COULD GO ONE OF TWO PLACES) NO MORE -- DCS
AOS LEVEL
PUSHJ P,MAKBUK ;DOWN A LEVEL
SKIPN SIMPSW ;IF NOT SIMPLE PROC
AOS CDLEV ;DOWN HERE TOO
TLO FF,NOCRFW!PRODEF ;SET DECLARATION BIT
; 3 -- ISSUE CODE
Comment ⊗ consider: ... X ← A+1;
BEGIN INTEGER PROCEDURE ... ⊗
TRNE TBITS2,FORWRD ;IF FORWARD DEC, IGNORE THE REST
JRST TMPOPJ ; (SOME OF ABOVE IS IRRELEVANT ALSO)
PUSHJ P,ZOTDIS
PUSHJ P,ALLSTO ;BECAUSE OF ABOVE CONSIDERATION
MOVE TEMP,CDLEV ;BUMP DISPLY LEVEL
MOVEI LPSA,RF
MOVEM LPSA,DISTAB(TEMP) ;F IS THE TOP DISPLAY
COMMENT ⊗ AT A LATER DATE MAY WANT TOO DO MORE --
I.E. BEFORE ALLSTO -- GO THRU ZZ CLEAR DISTAB SO
RECORD OF DISPLAYS GETS KEPT OVER PROC DECL;
⊗
;CREF THE NEW BLOCK NAME.
TLZ FF,NOCRFW
TLNN FF,CREFSW
JRST NOCRW ;NO
MOVEI A,15
PUSHJ P,CREFOUT
MOVE LPSA,PNT2
PUSHJ P,CREFASC
NOCRW:
HRRZ TEMP,PCNT ;ADDR OF JRST TO COME (IF ANY)
POP P,LPSA ;PTR TO 2D SEMBLK FOR SURROUNDING PROCEDURE
SKIPE $SBITS(LPSA) ;HAS SOMEBODY ALREADY DONE THE JUMP?
JRST NOROUND ; YES, ONLY ONE JUMP AROUND PROCEDURES
; (SEE ENDDEC, ENDJMP, BUILT-IN ARRAY CODE)
HRRZM TEMP,$SBITS(LPSA);DENOTE JRST FROM HERE
EMIT (<JRST NOUSAC+NOADDR>) ;JRST AROUND PROC(S)
HRRZ TEMP,PCNT ;NOW NEW PCNT
;;%BI% ! CHANGED THIS FROM HRLZM TEMP,$ACNO(PNT2)
NOROUND:HRLM TEMP,$VAL2(PNT2);IDENTIFIES START OF PROCEDURE
HLLZS $ACNO(PNT2) ;WAS PARANOID ABOUT THE ZEROING USED TO GET
;;%BI%
TLNE TBITS2,RECURS
JRST RCSV ;RECURSIVE, CAN'T PLACE PROC YET
TLNN TBITS2,SIMPLE ;IS THIS NON-SIMPLE AND
TLNN TBITS2,INTRNL ;IS THIS AN INTERNAL PROCEDURE??
JRST NTINT ;NO
;;#SD#
MOVEI A,1 ;FLAG THAT SAYS ALWAYS PUT OUT PDA WORD
PUSHJ P,PDAWRD ;YES, NEED A PDA WORD
;;#SD#
NTINT:
NRC <
SKIPE RCDFLG ;IF DECLARING A RECORD CLASS
JRST WAITAS ;THEN WAIT TO ASSIGN ADDRESS
>;NRC
HRL B,$ADR(PNT2) ;CAN NOW GIVE PROCEDURE A HOME
HRR B,PCNT ;AT PCNT NO LESS!
HRRM B,$ADR(PNT2)
TLNE B,-1 ;IF IT WAS FORWARD, AND SOMEONE
PUSHJ P,FBOUT ;HAD THE FORSIGHT TO USE IT.
TRZ TBITS2,INPROG
WAITAS: MOVEM TBITS2,$TBITS(PNT2); NO LONGER FORWARD
BAIL<
MOVE TEMP,BAILON
SKIPE SIMPSW ;SKIP IF NOT SIMPLE
TRNN TEMP,BBPDSM ;SKIP IF SIMPLE PROCS GET PD
JRST NTINT1 ;SAME AS USUAL
;;#%%# 2! JFR 2-1-75 RECORDS ARE SIMPLE PROCS IN DISGUISE, THE JFCL WAS KILLING THEM
SKIPE RCDFLG ;RECORD CLASS DECL IN PROGRESS?
JRST NTINT1 ;YES
EMIT (<JFCL NOUSAC+NOADDR>) ;GIVE BREAKPOINTS SOME BREATHING ROOM
HRRZ PNT,$VAL(PNT2) ;MY PD SEMBLK
HRRZ B,PCNT
HRLM B,$ACNO(PNT) ;PCNT AFTER "MKSEMT"
POPJ P,
NTINT1:
>;BAIL
SKIPE SIMPSW ;IF SIMPLE THEN ALL DONE
POPJ P,
PUSHJ P,MKSEMT ;PUT OUT MSCP
PUSHJ P,SETF ;MAKE IT ALL OFFICIAL
POPJ P,
↑↑TMPOPJ:POP P,TEMP
POPJ P,
PDAWRD: HRRZ PNT,$VAL(PNT2) ;LOOK AT PROCEDURE DESCRIPTOR
CAIN PNT,0 ;BETTER BE HERE
ERR <DRYROT -- DONT HAVE PD SEMBLK YET>
;;#SD# IF USED TO BE EXTERNAL WE NEED TO BE FANCY HERE (PERHAPS)
SKIPN IEFLAG ;INTERNAL TO EXTERNAL??
JRST PDAW.1 ;
HRLZ B,$ADR(PNT) ;PDA FIXUP CHAIN
JUMPE B,PDAW.1 ;
HRR B,PCNT ;
PUSHJ P,FBOUT ;FIX ALL THESE UP TO HERE
HLLZS $ADR(PNT) ;MAKE A FRESH START
PUSHJ P,FRBT ;LIKE SO
JRST .+2 ;WE REALLY NEED A PDA WORD
PDAW.1: JUMPE A,CPOPJ
;;#SH# ! ADDED A NOUSAC
EMIT <NOUSAC!JSFIX> ;PUT OUT PDA
HRRZ TEMP,PCNT ;AND YET ANOTHER VALUE FOR
HRLM TEMP,$VAL2(PNT2);PCNT AT PRDEC
POPJ P,
RCSV: SKIPN IEFLAG ;
POPJ P,
MOVEI A,0 ;ONLY PUT OUT PDA WORD IF NEED TO
JRST PDAWRD
;;#SD#
COMMENT ⊗ ENDPR -- when params have been seen⊗
DSCR ENDPR
PRO ENDPR
DES
PD1: PDEC ; drarrow PDEC EXEC ENDPR SCAN ¬S1
PDNO ; drarrow NIL EXEC ENDPR SCAN ¬DS0
1. Turn off formal-scanning bit
2. Save parameter counts, insert stack displacements
for parameters
⊗
; 1
↑ENDPR: TLZ FF,NOCRFW!PRODEF
; 2
HRRZ PNT2,GENLEF+1 ;THIS PROCEDURE
MOVE TEMP,$TBITS(PNT2) ;GET TYPE BITS
TLNN TEMP,MPBIND ;A MATCHING PROCEDURE?
JRST MATNOT ;NO
TLNE TEMP,SIMPLE ;BETTER NOT BE SIMPLE.
ERR <MATCHING PROCEDURES MAY NOT BE SIMPLE>,1
QPUSH (MPSTAK,PNT2) ;SEMANTICS OF MATCHING PROCEDURE
MATNOT:
HLRZ PNT2,%TLINK(PNT2) ;PTR TO SECOND BLOCK FOR THIS PROC
JUMPE PNT2,LPSERR ;HAS TO BE THERE
AOS A,APARNO ;SAVE COUNTS
HRLM A,$NPRMS(PNT2) ;SAVE COUNTS
MOVE A,SPARNO
LSH A,1 ; * 2 FOR STRINGS
HRRM A,$NPRMS(PNT2) ;AND SET UP A AND B WITH THEM
MOVEI A,1 ;LEAVE ROOM FOR RETURN ADDR
MOVEI B,1 ;LEAVE ROOM FOR SECOND STRING WORD
; NUMBER THE PARAMETERS, FIND BEGINNING OF THEIR LIST, REZERO VARB
SKIPN PNT,VARB ;ARE THERE ANY?
JRST PUTIN ; NO, MARK ZERO
PARD: PUSHJ P,GETAD ;FIND OUT ABOUT THIS FORMAL
TRNE TBITS,PROCED ;IF IT IS A PROCEDURE CALLED BY
TLNN TBITS,VALUE ; VALUE, COMPLAIN
SKIPA
ERR <DON'T PASS PROCEDURES BY VALUE>,1
TRNE TBITS,STRING ;STRING VALUE PARAMS ARE INDEXED
TLNN TBITS,VALUE ;FROM THE RSP STACK
JRST PST ;ALL OTHERS OFF OF RP
;;#HR# ALLOW STRING ITEMVAR PARAMETERS
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR]
;;#HR#
JRST PST
HRRM B,$ADR(PNT) ;DISPLACEMENT FROM TOP OF STACK
ADDI B,2 ;SIZE OF EACH PARAM
JRST PRLUP
PST: HRRM A,$ADR(PNT)
ADDI A,1
TRNE TBITS,SET
TDNE TBITS,[XWD REFRNC!SBSCRP,LPARRAY!ITEM!ITMVAR]
JRST NOSET ;EXCEPT THESE.
TRNE TBITS,FLOTNG ;DON'T LET CONTEXTS THROUGH
ERR <CONTEXTS MAY NOT BE PASSED BY VALUE>,1
; IF EXTERNAL (OR FORWARD) PROCEDURE, NO CODE GOES OUT (DCS -- 9/11/70)
; MORE FIXES 6-11-71
MOVE TEMP,GENLEF+1 ;PROC SEMANTICS
MOVE TEMP,$TBITS(TEMP)
TDNE TEMP,[XWD EXTRNL,FORWRD] ;SPECIAL DECLARATION?
JRST NOSET
; END BUG FIX (DCS -- 9/11/70) (6-11-71)
PUSH P,A
EMIT (<HRROI TAC1,NOUSAC>);CALL IT.
LPCALL (SETCOP) ;AND COPY IT.
POP P,A
NOSET:
TLNN TBITS,MPBIND ;A ?ITEMVAR
JRST NOMPRS ;NO.
MOVE TEMP,GENLEF+1 ;GET PROC'S SEMANTICS
MOVE TEMP,$TBITS(TEMP);
TDNE TEMP,[XWD EXTRNL,FORWRD]
JRST NOMPRS ;NO CODE FOR EXTERNS OF FORWARDS
TLNN TEMP,MPBIND ;THIS REALLY A MATCHING PROC.
ERR <? PARAMS ONLY LEGAL FOR MATCHING PROCEDURES>,1
PUSH P,A ;SAVE DISPLACEMENT
PUSH P,PNT ;SAVE
AOS MPQCNT ;WE HAVE ANOTHER ? PARAM
QPUSH (MPVARS,PNT) ;SAVE ? PARS SEMANTICS
;INITIALIZE ? PARAMS TO UNBOUND IF NECESSARY
MOVEI A,UNBND ;THE "UNBOUND" ITEM
PUSHJ P,CREINT ;GET CONSTANT SEMBLK
GENMOV (GET,0) ;
HRROS ACKTAB(D) ;PROTECT THAT AC
EXCH D,(P) ;SAVE AC # ITS IN
MOVE PNT,D ;THE PARAM SEMBLK
GENMOV (ACCESS,GETD) ;PROBABLY NOT NECESSARY
PUSHJ P,GETAN0 ;GET AN AC TO PLAY WITH
EMIT <MOVE ,0> ;LOAD PARAM
;NOTE GENMOV WILL NOT WORK HERE
;AS IT WOULD GENERATE MOVEI @
HRLM D,(P) ;TO USE AS INDX FOR MOVEM BELOW
HRLI C,20 ;THE INDIRECT BIT
EMIT <TLNE ,USADDR!NORLC> ;TEST FOR INDIRECT BIT
POP P,D ;AC CONTAINING "UNBOUND"
EMIT <MOVEM ,USX!NOADDR>
;; #LL# WAS UNPROTECTING WRONG AC
;; MOVSS D
HRRZS ACKTAB(D) ;"FREE" INDEX AC
POP P,A ;RESTORE DISPLACEMENT
NOMPRS:
PRLUP: LEFT PNT,%RVARB,PUTIN;NEXT ONE OR ZERO
MOVE PNT,LPSA ;PNT TO NEXT ONE
JRST PARD
PUTIN:
MOVE TEMP,GENLEF+1 ;GET PROC'S SEMANTICS
MOVE TEMP,$TBITS(TEMP)
;; #ME# FOLLOWING ONLY TESTED EXTRNL
TDNN TEMP,[EXTRNL,,FORWRD] ;IF EXTERNAL OR FORWARD DO NOTHING HERE
TLNN TEMP,MPBIND ;OR NOT MATCHING PROCEDURE
JRST PUTIN2 ;IGNORE
PUSH P,PNT
HRR C,PCNT
MOVE B,MPQCNT ; THE COUNT OF NUMBER OF ? PARAMETERS
ADDI C,2(B) ;
HRLI C,(C)
EMIT <JRST ,NOUSAC!USADDR> ;JRST AROUND ?TABLE
HRL PNT,PCNT ;SAVE ADDR OF TABLE
HRR PNT,LEVEL ;SAVE LEVEL FOR STKUWD
QPUSH (MPVSTK,PNT)
HRLI C,(B) ;NUMBER OF MP PARS
EMIT <,NOUSAC!USADDR!NORLC>;COUNT OF
;; #NP# CAN'T QPOP AN EMPTY STACK(MPVARS)
JUMPE B,NOQPARS ;IF NO PARAMS DO NOTHING
LBPUTL:
QPOP (MPVARS,PNT)
HRRZ C,$ADR(PNT) ;THE STACK DISPLACEMENT
MOVNS C
SUBI C,1 ;FOR RETURN ADDRESS
HRL C,C
EMIT <,USADDR!NOUSAC!NORLC>
SOJG B,LBPUTL
NOQPARS:
POP P,PNT
SETZM MPQCNT ;FOR NEXT TIME
PUTIN2:
HRLM PNT,%TLINK(PNT2) ;PNT2 pnts to 2D PROC BLOCK
SETZM VARB ;BRAND NEW PROC DECL COMING
;;#GP# DCS 2-6-72 (4-4) CHECK FORWARDS AGAINS NEW FORMALS
SKIPN LPSA,OLDPRM ;DID ANY FORWARD HAVE DECLRARATIONS?
JUMPE PNT,OKFORM ; NO, AND ALSO NO NEW DECLARATIONS
JUMPL LPSA,OKFORM ;NO PREVIOUS FORMALS, QUIT
SETOM OLDPRM ;CLEAR OUT, JUST FOR SAFETY
CKPRM: JUMPE LPSA,CHKRDN ;CHECK REAL DONE TOO
JUMPE PNT,TOOMF ;TOO MANY FORWARDS
PUSHJ P,URGSTR ;RELEASE FROM STRING RING
FREBLK () ;RELEASE STORAGE
MOVE TBITS,$TBITS(PNT)
CAME TBITS,$TBITS(LPSA);MUST BE SAME TYPE
ERR <FORMALS DON'T ALL AGREE WITH FORWARD DECLARATIONS>,1
HRRZ LPSA,%RVARB(LPSA);MOVE ON DOWN
HRRZ PNT,%RVARB(PNT)
JRST CKPRM
CHKRDN: JUMPE PNT,OKFORM ;MUST BOTH BE EMPTY
ERR <MORE FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
OKFORM: POPJ P,
TOOMF: ERR <FEWER FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
JRST KILLST ;REMOVE THE REST
;;#GP# (4)
;; ENDRC -- MAIN RECORD CLASS EXEC
REC <
; Any resemblence between this routine & ENDPR or PRUP is strictly
; intentional
ZERODATA(SOME VARIABLES FOR RCLASS EMISSION)
TARAPC: 0 ;PROGRAM COUNTER AT START OF TYPE ARRAY
IDRAPC: 0 ;PC AT START OF ID ARRAY
PNSTPC: 0 ;PC AT START OF PNAME STRING
CLSBTS: 0 ;HOLDS TYPE BITS
NOFLID: 0 ;IF NON-ZERO, NO FIELD PNAMES GO OUT
ENDDATA
↑ENDRC: TLZ FF,NOCRFW!PRODEF ;MAKE THE SCANNER HAPPY
SETZM CURRCC ;DONE WITH THIS NOW
HRRZ PNT2,GENLEF+1 ;THE "PROCEDURE"
PUSHJ P,GETAD2 ;IF EXTERNAL OR FORWARD, DO NOTHING
HLRZ PNT2,%TLINK(PNT2) ;GET THE SECOND BLOCK
NONRC<
SKIPE A,SPARNO ;PARAMETER COUNT
ERR <STRING SUBFIELDS FOR RECORDS NOT YET IMPLEMENTED>,1
>;NONRC
NRC<
MOVE A,SPARNO
>;NRC
ADD A,APARNO ;NUMBER OF PARAMETERS
MOVEM A,$NPRMS(PNT2) ;
NONRC <
TDNE TBITS2,[XWD EXTRNL,FORWRD] ;CHECK TO SEE IF SHOULD PUT OUT
JRST FLDCHK ;NOTHING GOES OUT
LSH A,=23 ;TURN THE WORD COUNT INTO "OPCODE"
SKIPE PNT,URCIPR ;DID THE USER SPECIFY A HANDLER
JRST [ PUSHJ P,GETAD
HRL C,$ADR(PNT) ;
TRNE TBITS,FORWRD!INPROG ;WELL??
TROA A,NOUSAC!JSFIX ;YES, LET EMITER DO FIXUP
TRO A,NOUSAC!USADDR ;
JRST HLRWRD
]
HRLZ C,PCNT ;USE THE STANDARD ROUTINE $REC$
EXCH C,LIBTAB+R$REC$ ;DO FIXUP MYSELF
HRRI A,NOUSAC!USADDR ;& PUT OUT THE INSTRUCTION
HLRWRD: PUSHJ P,EMITER ;PUT OUT THE HANDLER WORD
>;NONRC
FLDCHK:
NRC <
MOVEI B,CMPLDC ;NO DELETE & COMPILED-IN
>;NRC
SKIPN LPSA,VARB ;ARE THERE ANY FIELDS
JRST NOFLDS ;NOPE
HRRZ A,$NPRMS(PNT2) ;HOW MANY THERE ARE
HRLZI TBITS,FORMAL ;TURN OFF THE FORMALNESS
ZRTB: ANDCAM TBITS,$TBITS(LPSA) ;OF THIS PARAMETER
NRC <
MOVE C,$TBITS(LPSA) ;GET TBITS
TRNE C,ITMVAR!ITEM ;AN ITEMISH THING?
JRST FPISIV ;YES
TRNE C,STRING ;A STRING?
TRO B,HASSTR ;HAVE SOME SORT OF STRING PARAM
TRNE C,PNTVAR ;PERCHANCE A RECORD CLASS
TRO B,HASRPS ;YES
FPISIV:
>;NRC
MOVEM A,$ADR(LPSA) ;INDEX
SOJLE A,RMFP ;REMEMBER THIS ONE
;;#VB# (1 OF 3) MISPLACED CODE USED TO BE HERE RHT
HLRZ LPSA,%RVARB(LPSA) ;GO LEFT,YOUNG MAN
JUMPN LPSA,ZRTB ;
ERR <DRYROT: INDEX COUNT & PARAM RING DISAGREE>,1
;;#VB# (2 OF 3) ! PUT NOFLDS IN RIGHT PLACE
NRC <
NOFLDS:
>;NRC
RMFP: HRLM LPSA,%TLINK(PNT2) ;NOW LPSA HOLDS PTR TO FIRST
;;#VB# (3 OF 3) RHT
NRC <
MOVEM B,CLSBTS ;REMEMBER CLASS BITS
>;NRC
;;#VB#
TDNE TBITS2,[XWD EXTRNL,FORWRD] ;IF ONE OF THESE, NO CODE
JRST RCBDON
NRC <
REN <
PUSHJ P,HISET ;FORCE INTO HIGH SEGMENT
>;REN
PUSH P,FF ;PARANOIA
TLO FF,RELOC ;
MOVE A,PCNT ;
MOVEM A,TARAPC ;TYPE ARRAY PC
ADDI A,5 ;POINT AT FIRST WORD OF ARRAY
PUSHJ P,CODOUT
PUSHJ P,[ARBNDP: TLZ FF,RELOC ;PUT OUT BOUNDS PAIRS
MOVEI A,0
PUSHJ P,CODOUT ;LOWER BND
HRRZ A,$NPRMS(PNT2) ;
PUSHJ P,CODOUT ;UPPER BND
MOVEI A,1 ;MULT
PUSHJ P,CODOUT
POPJ P, ]
HRRZ A,$NPRMS(PNT2)
ADD A,X11 ; NDIMS,,LEN
PUSHJ P,CODOUT ; PUT OUT THAT WORD
MOVE A,CLSBTS ; *** HERE IS WHERE TYPE BITS GO ***
PUSHJ P,CODOUT ; PUT OUT TYPE BITS
HLRZ LPSA,%TLINK(PNT2) ;IN CASE WAS MUNCHED (MOST LIKELY WAS OK)
PUSHJ P,TBCOUT ;
MOVE PNT,GENLEF+1 ;PICK UP THE CLASS DESCRIPTOR
EXCH SP,STPSAV ;SINCE WILL CALL CAT
PUSHJ P,INSET ;WE WILL ALWAYS PUT OUT CLASSID CHARS
PUSH SP,$PNAME(PNT) ;CLASSID
PUSH SP,$PNAME+1(PNT)
PUSH P,[0]
EXTERN CATCHR
PUSHJ P,CATCHR ;NOW ASCII WITH A ZERO
SKIPE NOFLID ;WANT IDS
JRST CHRSDO ;NO, JUST PUT OUT WHAT YOU HAVE
HLRZ B,%TLINK(PNT2) ;FIRST FIELD
JUMPE B,CHRSDO ;NO FIELDS
FIDSLP: PUSH SP,$PNAME(B) ;PNAME OF PARAMETER
PUSH SP,$PNAME+1(B)
PUSHJ P,CAT ;CONCATENATE IT ON
HRRZ B,%RVARB(B) ;GET THE NEXT ONE
JUMPN B,FIDSLP ;CONTINUE ON
CHRSDO:
POP SP,B ;POINT AT TEXT
POP SP,C ;CHARACTER COUNT
EXCH SP,STPSAV ;PUT SP BACK TOGETHER
HRRZ C,C ;WANT THE BYTE COUNT
MOVE A,PCNT ;REMEMBER HERE
MOVEM A,PNSTPC ;SO CAN BUILD DESCRIPTORS
CHRSD1: MOVE A,(B) ;A WORD OF TEXT
PUSHJ P,CODOUT ;PUT IT OUT
SUBI C,5 ;5 CHARS WENT OUT
CAILE C,0 ;DONE
AOJA B,CHRSD1 ;DO, GO DO SOME MORE
SETZM IDRAPC ;
SKIPE NOFLID ;WANT ID FIELDS TO GO OUT
JRST FIDSDN ;NO, THEN WE ARE DONE WITH IDS
MOVE A,PCNT ;REMEMBER WHERE STRING ARRAY STARTS
MOVEM A,IDRAPC ;
;;#XK# ! JFR 7-30-76 STRING ARRAYS HAVE -1 IN LEFT HALF OF WORD CONTAINING 000 ADDR
HRROI A,6(A) ;FIRST DATA ENTRY
TLO FF,RELOC
PUSHJ P,CODOUT
PUSHJ P,ARBNDP ;PUT OUT ARRAY BOUNDS PAIR
HRRZ A,$NPRMS(PNT2) ;COUNT WORD
LSH A,1
HRROI A,2(A) ;-1,,2(N+1)
PUSHJ P,CODOUT ;
MOVE D,PNSTPC ;PC AT START OF PNAME STRING
HRLI D,(<POINT 7,0>) ;MAKE IT A BYTE POINTER
HRRZ C,$PNAME(PNT) ;BYTE CNT OF ID
PUSHJ P,[BPEMT: TLZ FF,RELOC
MOVE A,C ;PUT OUT COUNT
PUSHJ P,CODOUT;
TLO FF,RELOC;
MOVE A,D ;PUT OUT BPTR
PUSHJ P,CODOUT
JUMPE C,CPOPJ ;
BPEMT0: IBP D ;INCREMENT POINTER
SOJG C,BPEMT0;THAT MANY TIMES
POPJ P,]
IBP D ;FOR THE 0 BYTE
HLRZ B,%TLINK(PNT2) ;PUT OUT STRINGS FOR FIELDS
JUMPE B,FIDSDN ;DONE
FID1DO: HRRZ C,$PNAME(B) ;LENGHT OF THIS ONE
PUSHJ P,BPEMT ;PUT OUT
HRRZ B,%RVARB(B) ;NEXT
JUMPN B,FID1DO
;; HERE PUT OUT THE ACTUAL DESCRIPTOR
FIDSDN:
REN <
PUSHJ P,LOSET ;THIS GOES INTO THE LOW SEGMENT
>;REN
TLZ FF,RELOC
MOVEI A,0 ;RECORD CLASS LINK WORD
PUSHJ P,CODOUT ;
MOVEI B,%RCLNK ;LINK ONTO THE RECORD CLASS LIST
PUSHJ P,LNKOUT ;PUT IT OUT
MOVEI A,0 ;THE RING WORD
PUSHJ P,CODOUT
;; NOW GIVE RECORD CLASS AN ADDRESS
MOVE PNT,GENLEF+1
HRL B,$ADR(PNT) ;PICK UP ADDRESS
HRR B,PCNT ;AT PCNT NO LESS!
HRRM B,$ADR(PNT)
TLNE B,-1 ;IF IT WAS FORWARD, AND SOMEONE
PUSHJ P,FBOUT ;HAD THE FORSIGHT TO USE IT.
MOVEI TBITS2,INPROG ;TURN OFF INPROG
ANDCAM TBITS2,$TBITS(PNT)
;; NOW PUT OUT THE FIRST "REAL" WORD OF THE DESCRIPTOR
HRLZ C,PCNT ;
EXCH C,LIBTAB+R$CLASS ;DO FIXUP MYSELF
HRRI A,NOUSAC!USADDR ;& PUT OUT THE INSTRUCTION
PUSHJ P,EMITER ;PUT OUT THE CLASSID WORD
TLZ FF,RELOC
MOVEI A,0 ;THE RECRNG WORD
PUSHJ P,CODOUT
SKIPE PNT,URCIPR ;DID THE USER SPECIFY A HANDLER
JRST [ PUSHJ P,GETAD
HRL C,$ADR(PNT) ;
TRNE TBITS,FORWRD!INPROG ;WELL??
TROA A,NOUSAC!JSFIX ;YES, LET EMITER DO FIXUP
TRO A,NOUSAC!USADDR ;
JRST HLRWRD
]
HRLZ C,PCNT ;USE THE STANDARD ROUTINE $REC$
EXCH C,LIBTAB+R$REC$ ;DO FIXUP MYSELF
MOVEI A,NOUSAC!USADDR ;& PUT OUT THE INSTRUCTION
HLRWRD: PUSHJ P,EMITER ;PUT OUT THE HANDLER WORD
;;#UG# ! REMEMBER NOT TO RELOCATE THE COUNT
TLZ FF,RELOC ;GOES OUT UNRELOCATED
MOVE A,$NPRMS(PNT2) ;WORD COUNT
PUSHJ P,CODOUT
MOVE A,TARAPC ;PC OF TYPE ARRAY
ADDI A,5 ;FOR ARRAY HEAD
TLO FF,RELOC
PUSHJ P,CODOUT ;PUT IT OUT
SKIPN A,IDRAPC ;ID ARRAY
TLZA FF,RELOC ;A ZERO
ADDI A,6 ;TO RIGHT PLACE
PUSHJ P,CODOUT ;PUT OUT
POP P,FF ;GET FF BACK
REN <
PUSHJ P,HISET ;BACK TO HIGH SEGMENT
>;REN
>;NRC
NONRC <
PUSHJ P,TBCOUT ;PUT OUT THE CODES FOR THESE
NOFLDS: MOVEI A,0 ;
PUSHJ P,CODOUT ;A ZERO TO SAY DONE
;;%BN% PUT OUT ASCIZ/CLASSID/ & A SAIL STRING POINTER THERETO
MOVE PNT,GENLEF+1
PUSH P,FF ;SUPER PARANOID
TLZ FF,RELOC
HRRZ A,$PNAME(PNT);
PUSHJ P,CODOUT
HRRZ B,A
HRRZ A,PCNT
ADD A,[POINT 7,1]
TLO FF,RELOC
PUSHJ P,CODOUT ;PUT OUT THE BYTE PTR
MOVE D,$PNAME+1(PNT) ;THE BYTE POINTER WORD OF ID
IDIVI B,5 ;NUMBER OF WORDS
CAIE C,0 ;IF NO REMAINDER
ADDI B,1 ;THEN WE WILL EVENTUALLY PUT OUT A
TLZ FF,RELOC ;WHOLE WORD OF 0
CIDLP: MOVE A,(D) ;A WORD FULL OF TEXT
PUSHJ P,CODOUT
ADDI D,1
SOJG B,CIDLP
JUMPN C,.+3
MOVEI A,0
PUSHJ P,CODOUT
POP P,FF
;;%BN%
>;NONRC
RCBDON: ;WELL, THE BODY IS OUT NOW
HLRZ PNT,%TLINK(PNT2) ;PRE-CONDITION FOR PUTIN2
PUSHJ P,PUTIN2 ;CHECK AGAINST POSSIBLE FORWARDS
;(PRETENDING TO BE ENDPR, REMEMBER)
RPRUP: SETZM BITS ;NOW DO THE PRUPISH THINGS
SETZM ALOCALS ;MOST LIKELY MOOT, BUT DOESN'T HURT
SETZM SLOCALS
QPOP (FORMFX) ;THIS ARCHAIC THING SHOULD BE FLUSHED
JUMPGE A,FFXERR ;THE "MARK" WAS NEGATIVE
MOVE PNT,GENLEF+1 ;JUST TO KEEP MY HEAD STRAIGHT
PUSHJ P,GETAD ;PROC SEMANTICS
PUSHJ P,SYNTUP ;NOTE STILL PRETENDING TO BE SIMPLE PROC
MOVE PNT,GENLEF+1 ;FOR SAFETY
MOVE TBITS,[XWD SIMPLE,PROCED!PNTVAR!SHORT]
XORM TBITS,$TBITS(PNT) ;TELL THE TRUTH ABOUT WHAT IT IS
POPJ P, ;HOPE IT WORKS
>;REC
COMMENT ⊗ PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.⊗
DSCR PRUP
PRO PRUP
RES
at S8: PDEC S ; drarrow NIL EXEC PRUP SCAN ¬DS
1. Issues fixups for any jumps to procedure exit, and
for the jump around the procedure.
2. Issues procedure exit code, including stack adjusts
3. Issues procedure entry code if the procedure is recursive,
including a JRST to the procedure text.
4. Goes up a text level, restores VARB-type pointers
5. Allocates storage for locals to procedure (ALOT).
BITS used as special flag during PRUP (see NONULL+1)
⊗
↑PRUP: PUSHJ P,ALLSTO ;STORE ALLES NOT YET STORED
SETZM BITS ;NOT SPECIAL YET (BITS USED AS FLAG)
GETSM2 (2) ;PROCEDURE SEMANTICS
;;#HS# STRING ITEMVAR PROC TO BE TREATED AS ITEMVAR PROC. NOT STRING
TRNE TBITS2,ITEM!ITMVAR
TRZ TBITS2,STRING
;;#HS#
;⊗⊗ PNT2 set will almost continuously have Proc Semantics in the sequel
HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK
MOVE TEMP,PCNT ;PICK UP PCNT
HRRM TEMP,$ACNO(PNT) ;
TLNN TBITS2,MPBIND ;THIS A MATCHING PROC
JRST MPNO ;NO
QPOP (MPSTAK)
CAIE PNT2,(A) ;THE SAME?
ERR <DRYROT-PRUP MATCHING PROC>
EMIT <HRRZI LPSA,NOUSAC> ;ADDRESS OF PDA
;; #LK# BY JRL FOLLOWING WAS QPOP
QPOP (MPVSTK,C) ;THIS IS QPOP AGAIN, SINCE PEXIT NO LONGER
;REFERS TO IT
;; #LK#
EMIT <HRLI LPSA,NOUSAC!USADDR>;ADDRESS OF ?TAB
HRLI C,LPSA
EMIT <PUSH RP,NOUSAC!USADDR!NORLC> ;STACK PDA ADDRESS
XCALL (.FAIL) ;REPORT FAILURE
EMIT <SETZ 1,NOUSAC!NOADDR> ;FALLING THROUGH IS FALSE
PUSHJ P,EMITER ;BOTH NORMAL RETURN AND SKIP RETURN
MPNO:
PUSH P,TBITS2 ;REST WILL BE RECONSTRUCTED LATER
TRNE TBITS2,STRING ;IF NO RETURN MADE FROM STRING
TLNE SBITS2,RTNDON ; PROC, RETURN NULL HERE
JRST NONULL
SETZM PNAME
PUSHJ P,STRINS
GENMOV (STACK,REM) ;STACK IT AND FORGET IT
SETZM SDEPTH ;WE KNOW ABOUT STACK HERE
JRST NOEXIT ;BYPASS SPECIAL TEST (MUST HAVE SUB/PUSH CODE)
NONULL: HRLZ B,$ACNO(PNT2)
JUMPE B,[SETOM BITS ;NOBODY JUMPED TO SUB/PUSH CODE, BUT SOMEBODY
TLNE SBITS2,RTNDON ;RETURNED, SO SET SPEC (DON'T GENERATE
TRNN TBITS2,STRING ; SUB/PUSH) -- ONLY IF STRING PROC AND
SETZM BITS ; SOMEBODY RETURNED (TO EXIT2, ACTUALLY)
JRST NOEXIT]; NO FIXUP, IN ANY CASE
HRR B,PCNT ;EXIT TO HERE
PUSHJ P,FBOUT ; IF YOU CAN
Comment ⊗ Now call routine which obtains the necessary
counts and such (if the procedure is recursive). ⊗
NOEXIT:
TLZ FF,ALLOCT ; GET SIZES
PUSHJ P,ALOT
POP P,TBITS2 ;GET PROC TYPES BACK
TLNN TBITS2,RECURS ;RECURSIVE PROCEDURE?
JRST NOREC1 ; NO
; FIX UP ANY REFERENCES TO THE FORMALS OF THIS PROCEDURE
FFXLUP: QPOP (FORMFX) ;A pnts to [DISPL REL 0,ADDR OF INSTR]
JUMPL A,FFXERR ;MUST NOT BE NEGATIVE
JUMPLE A,PEXIT ;GO GENERATE EXIT CODE WHEN DONE
FFXERR: ERR <DRYROT -- FFXLUP>
NOREC1: SETZM ALOCALS ;DON'T INCLUDE IN STACK COUNTS
SETZM SLOCALS
QPOP (FORMFX) ;GET STACK POINTER OFF
JUMPGE A,FFXERR ;MUST BE NEGATIVE -- NO RECURSION
Comment ⊗ Generate procedure exit code -- local restore, subs, push str results ⊗
PEXIT: GETSM2 (2) ;PROCEDURE SEMANTICS AGAIN
;;#HS# IGNORE STRING BIT FOR STRING ITEMVAR PROC.
TRNE TBITS2,ITEM!ITMVAR
TRZ TBITS2,STRING
;;#HS#
LEFT PNT2,%TLINK,LPSERR;LPSA pnts to SECOND BLOCK
PUSH P,$NPRMS(LPSA) ;NUMBERS OF PARAMS
;;#IP# RHT 7-18-72 RELEASE ANY VALUE SETS
;;#JK# RHT 10-3-72 (1 OF 3) !
TLZ FF,FFTEMP ;HAVENT RELEASED SETS YET
HLRZ PNT,%TBUCK(LPSA);POINT AT FIRST FORMAL
FRSV: JUMPE PNT,PEX2 ;ANY LEFT TO LOOK AT??
MOVE TBITS,$TBITS(PNT)
TRNE TBITS,ITEM!ITMVAR
JRST NXF
REC <
NORGC <
TLNN TBITS,VALUE ;IF NOT VALUE
JRST NXF ;NO WORRY AT ALL
TRNE TBITS,PNTVAR ;A RECORD POINTR
TRNE TBITS,777777-(PNTVAR!GLOBL)
JRST SETCHK ;NOPE
MOVNI C,1 ;GO DEREFERENCE THIS FELLOW
PUSHJ P,RFCADJ
JRST NXF ;GO LOOK AT NEXT FORMAL PARAMETER
SETCHK:
>;NORGC
RGC <
TLNE TBITS,VALUE
>;RGC
>;REC
NOREC <
TLNE TBITS,VALUE ;IF NOT VALUE
>;NOREC
TRNN TBITS,SET ;OR NOT SET THEN
JRST NXF ;GO ON TO NEXT
EMIT <HRROI TEMP,NOUSAC> ;CODE TO RELEASE THE SET
;; #JK# BY JRL 10-3-72 SAVE AC 1 OVER LEAP CALL
TRNE TBITS2,ALTYPS≠<PROCED+FORTRAN+STRING> ;WAS THIS A TYPED PROCEDURE
TLOE FF,FFTEMP ;DO WE HAVE TO SAVE AC1??
JRST STRCLX ;ALREADY DONE IT
HRLI C,A ;WILL SAVE AC 1 OVER LPCALL
EMIT <PUSH RP,NOUSAC!USADDR!NORLC>
;;#QX# RHT ! NEED TO BOOKKEEP (1 OF 2) 1-31-74
AOS ADEPTH
STRCLX: LPCALL (SETRCL) ;
;; #JK#
NXF: HRRZ PNT,%RVARB(PNT) ;ON TO NEXT
JRST FRSV
PEX2:
;;#JK# RHT 13-3-72 3 OF 3
HRLI C,A ;RESTORE AC1 IF NEED
MOVE A,[POP RP,NOUSAC!USADDR!NORLC] ;
TLNE FF,FFTEMP ;DID WE SAVE IT
;;#QX# RHT ! FOR 2 (2 OF 2)
PUSHJ P,[ SOS ADEPTH ;PUT IT BACK
JRST EMITER ]
;;#JK#
;;#IP#
SKIPGE BITS ;SPECIAL?
JRST DNTPSH ; YES, NO NEED SUBS OR PUSHES (DONE BFORE RETURN)
MOVE PNT,SLIMS ;VBL DESCRIPTOR BOUNDARIES
MOVE A,SSDIS ;STRING STACK DISPL
MOVEI D,RSP ;INDICATE USE OF SP STACK
;⊗ PNT is Sem of last,,Sem of 1st; A is # str locs, RH(P) is #str params
PUSHJ P,RESTOR ;ADJUST THE STACK, RESTORE LOCALS
; NOW PUSH RESULT INTO CORRECT STACK LOC IF NECESSARY
TRNE TBITS2,STRING ;STRING PROCEDURE WHICH REQUIRED A SUB?
CAIG B,2 ; (SET BY RESTOR, NUMBER SUBTRACTED)
JRST DNTPSH ; NO, NOT STRING OR RESULT IN RIGHT PLACE
HRLI C,-1(B) ;RELATIVE LOCATION OF RESULT TO CURRENT SP
EMIT <PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)
EMIT <PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)
; NOW ISSUE FIXUP FOR JUMPS AROUND ABOVE SUB/PUSH CODE
DNTPSH: SETZM BITS ;DON'T LEAVE BITS SCREWED UP
HLLZ B,$ADR(PNT2) ;THAT SPECIAL FIXUP
JUMPE B,NO2XIT ;NOBODY RETURNED NON-TEMP RESULT
HRR B,PCNT ;ISSUE FIXUP
PUSHJ P,FBOUT ;DOESN'T HAPPEN IN RECURSIVE PROCEDURES
NO2XIT:
SKIPE SIMPSW ;IF SIMPLE
JRST DOOUT ;NO NEED TO MANGLE F
MOVEI C,0 ;
EMIT (<MOVE RF,USADDR!NOUSAC!NORLC(RF)>); RESET RF
DOOUT: MOVSS (P) ;WANT NO ARITH PARAMS
MOVEI D,RP ;WANT RP
MOVE A,ASDIS ;ARTIH STACK DISPL
SKIPN SIMPSW ;ONLY HAVE FOR NON SIMPLE
ADDI A,1 ;SINCE (F) TAKES UP A WORD
HRRZ TEMP,(P) ;NOW CONSIDER THE CASE WHERE THERE
ADDI TEMP,-1(A) ; ARE NO LOCALS OR PARAMETERS
TRNN TEMP,-1 ;
JRST [EMIT (<POPJ RP,NOUSAC+NOADDR>) ;(ONLY A RETURN
JRST PENTRY] ;ADDRESS) -- DO POPJ
MOVE PNT,ALIMS ;PNT, A, D, (P) SET UP ANALAGOUS TO ABOVE CALL
PUSHJ P,RESTOR ;RESTORE THE P SIDE
HRLZ C,(P) ;NUMBER OF ARITH PARAMS.
HRLI D,RP ;USE THIS STACK AS INDEX
EMIT (<JRST USADDR+INDRCT+NORLC+USX+NOUSAC+JSFIX>);JRST @PARAMS(RP)
; NOW PRODUCE PROCEDURE ENTRY CODE IF RECURSIVE PROCEDURE
PENTRY: POP P,TEMP ;THROW THE #PARAMS PAIR AWAY
TLNN TBITS2,RECURS ;
JRST PRUPYU ;NOT RECURSIVE
TRZN TBITS2,INPROG ;NO LONGER FORWARD
; ***** BUG TRAP
ERR <DRYROT -- PENTRY>
HRRM TBITS2,$TBITS(PNT2) ;OFF IN MEMORY
;NOW, IF INTERNAL, PUT OUT PDA WORD
TLNN TBITS2,INTRNL ;IS THIS AN INTERNAL PROCEDURE??
JRST NOIN.1 ;NO
HRRZ PNT,$VAL(PNT2) ;LOOK AT PROCEDURE DESCRIPTOR
CAIN PNT,0 ;BETTER BE HERE
ERR <DRYROT -- DONT HAVE PD SEMBLK YET>
;;#SH# ! ADDED NOUSAC
EMIT <NOUSAC!JSFIX> ;PUT OUT PDA
;NOW THE PDA WORD IS OUT, IF NEED BE
NOIN.1: HRLZ B,$ADR(PNT2) ;FIXUP FOR EARLY JUMPS
HRR B,PCNT
HRRM B,$ADR(PNT2) ;THIS IS PROCEDURE ADDRESS
TLNE B,-1 ;DID ANYONE CALL EARLY?
PUSHJ P,FBOUT ;ADDR,,FIXUP FOR EARLY CALLS
PUSHJ P,MKSEMT ;MARK THE STACK
MOVEI D,RP ;DO ARITH SAVES
MOVE A,ASDIS ;STACK DISPL
SUBI A,2 ;FOR MSCP
CAILE A,0 ;IF ANY ARITH LOCALS
PUSHJ P,SAVIT ;ZERO THE APPROPRIATE STUFF
MOVEI D,RSP ;STRING STACK
SKIPE A,SSDIS ;IF STRING LOCALS, BLT THEM TOO
PUSHJ P,SAVIT
PUSHJ P,SETF ;MAKE IT OFFICIAL
;; ! %BI% USED TO BE $ACNO
HLL C,$VAL2(PNT2) ;TEXT ADDR (OF AOS IF THERE IS ONE)
EMIT (<JRST NOUSAC+USADDR>)
PRUPYU:
BAIL<
MOVE TEMP,PCNT
HRRZ LPSA,$VAL(PNT2) ;PD SEMBLK
SKIPE LPSA
HRLM TEMP,$VAL2(LPSA);ADDR OF LAST WORD OF CODE TO PD SEMBLK
>;BAIL
TLO FF,ALLOCT ;***** ASSUME SAVES ACS
PUSHJ P,ALOT ;ALLOCATE THE STORAGE
GETSEM (2) ;PROC SEMANTICS BACK
PUSHJ P,LNKMAK ;PUT OUT STRING LINK BLOCK IF NECESSARY
Comment ⊗ Now fix some syntactic things (restore counts,
pointers, etc.), go up a level, and quit . ⊗
SYNTUP: LEFT PNT,%TLINK,LPSERR
HRRZM PNT,VARB ;CAN ADD ON FROM HERE
SKIPE $VAL(LPSA) ;RETURNING TO TOP LEVEL?
TLO FF,TOPLEV ; YES, RESET BIT
MOVEW (BLKIDX,<$BLKLP(LPSA)>) ;RESTORE OLD BLKIDX
MOVE TEMP,%SAVET(LPSA)
HRRZM TEMP,TPROC ;RESTORE VARB STRUCTURE POINTERS
HLRZM TEMP,TTOP
MOVE A,$TBITS(TEMP) ;PICK UP TYPE BITS OF PROC
;;#KB# RHT ! 1 OF 2 (11-11-72) MUST SAVE LPSA
PUSH P,LPSA ;SAVE THE LIFE OF MY AC
PUSHJ P,ZOTDIS
;;#KB# 2 OF 2 !
POP P,LPSA ;CRIED THHE DESPARATE PROGRAMMER
SKIPE SIMPSW ;
SKIPA TEMP,CDLEV
SOS TEMP,CDLEV ;
HRLI TEMP,RF ;PUT RF BACK RIGHT
HLRZM TEMP,DISTAB(TEMP);
SETZM RECSW ;ASSUME DADDY NOT RECURSIVE
TLNE A,RECURS ;UNLESS HE WAS
SETOM RECSW ;THEN SAY SO
SETZM SIMPSW ;RESTORE SIMPLE PROCEDURE FLAG
TLNE A,SIMPLE
SETOM SIMPSW ;SAY IT IS SIMPLE
HRRZ TEMP,TPROC ;GET IT BACK FOR THE NEXT LOAD
HLRZ A,%TLINK(TEMP) ;RIGHT TEMP,%TLINK,
JUMPE A,LPSERR ; LPSERR
RGC <
HLRZ TEMP,%RVARB(A) ;RCTEMP LIST
MOVEM TEMP,RCTEMP
>;RGC
MOVE TEMP,%STEMP(A) ;GET PARTIAL CORE TEMP LIST BACK
HRRZM TEMP,TTEMP ;RESTORE TO RIGHTFUL POSITION
SOS NMLVL ;REDUCE DDT LEVEL
SOS LEVEL ;UP A LEVEL
PUSHJ P,CLRSET ;CLEAR OUT BITS
TLNN FF,CREFSW ;IF CREFFING, PUT OUT SYMBOLS FOR FORMALS.
JRST FREBUK ;RELEASE OLD BUCKET, RETURN
HLRZ LPSA,%TBUCK(LPSA) ; TO FIRST FORMAL.
CRFNO: JUMPE LPSA,FREBUK ;ALL DONE.
PUSHJ P,CREFDEF ;SYMBOL DEFINITION.
HRRZ LPSA,%RVARB(LPSA)
JRST CRFNO
Comment ⊗ FORWRD declarations come here to undo damage
at PD1: PDNO ; drarrow NIL EXEC FWUNDO SCAN ¬DS0
⊗
↑FWUNDO:
QPOP (FORMFX) ;GET STACK MARKER OFF
; ***** BUG TRAP
SKIPLE A ;MUST NOT HAVE PUT ANYTHING ON
ERR <DRYROT -- FWUNDO>
GETSEM (1)
JRST SYNTUP ;UP A LEVEL, RESET LIST POINTERS, ETC.
COMMENT ⊗ RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
PAR (P)rh = #PARAMS (size of params)
A = #LOCALS (size of)
PNT = SEMANTICS OF LAST,,SEMANTICS OF FIRST TO BE RESTORED
RES B=# words subtracted
DES Sub sum of both from stack ref'ed in D if there are any (incl Str res in SUB)
BLT from 1+paramsize(stack) to first local, ending at last local, if recursive ⊗
RESTOR: PUSH P,PNT ;SAVE POINTERS
PUSH P,A ;SAVE # LOCALS
MOVEI B,0 ;IN CASE NONE SUBTRACTED
ADD A,-3(P) ;TOTAL TO SUBTRACT
HRLS A ;XWD
JUMPE A,RESDUN ;NOTHING TO DO AT ALL
ADD A,X22 ;IF STRING PROCEDURE WITH ANY LOCALS OR PARAMS,
CAIN D,RSP ; AND ADJUSTING STRING STACK, SUBTRACT AN EXTRA
TRNN TBITS2,STRING
SUB A,X22 ; TWO WORDS TO ACCOUNT FOR STRING RESULT
;;%DN% JFR 7-4-76
MOVEI B,(A) ;LIKE WE PROMISED
MOVNI TEMP,(A) ;NEGATE FOR ADJSP
HRLI C,(TEMP) ;INTO DISPL. FIELD
PUSHJ P,EADJSP
;; PUSHJ P,CREINT
;; HRRZ B,$VAL(PNT) ;TOTAL NUMBER SUBTRACTED
;; MOVE A,[SUB] ;RESULTS TO PNT -- SOME OF THESE
;; PUSHJ P,EMITER ;EMITS SHOULD EVENTUALLY BE COMBINED
;;%DN% ↑
RESDUN: POP P,A ;REMOVE #PARAMS WORD
POP P,PNT ;SAVED PNT
POPJ P,
Comment ⊗
IN: A -- #locals
D -- stack #
PNT -- end,start semantics
⊗
SAVIT:
PUSH P,PNT
PUSH P,A
MOVEI A,0 ;CREATE A ZERO
PUSHJ P,CREINT ;GET A ZERO
EMIT (<PUSH >) ; PUSH IT ONTO STACK
SOSG A,(P) ;ONE LESS ZERO TO BLT
JRST PSH1.1 ;NOTHING LEFT TO DO
CAILE A,4 ;BLT CHEAPER ONLY IF >4 MORE
JRST BLTIT ;
PSH1: EMIT (<PUSH >) ;PUSH A ZIP ON
SOSLE (P) ;COUNT DOWN
JRST PSH1 ;GO PUSH ANOTHER
PSH1.1: POP P,A ;GET A BACK
POP P,PNT ;GET IT BACK
POPJ P, ;THATS ALL
BLTIT: ;WE WILL DO A BLT
HRL D,D ;NEED STACK NO AS INX
MOVEI C,0 ;ZERO DISPL
EMIT(<HRLI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;FROM HERE
HRLI C,1 ;DISPL OF ONE
EMIT(<HRRI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;TO THERE
;NOW FOR THE ADD
;;%DN%
HRL C,(P) ;COUNT
PUSHJ P,EADJSP ;ADJUST THE STACK
MOVE TEMP,ASWITCH
TRNE TEMP,AADJSP
JRST BLTADN ;WE DID ADJSP, NO NEED FOR SKIPL AND PUSHJ $PDLOV
;; MOVE A,(P) ;GET THE COUNT INTO A
;; HRLS A ;XWD
;; PUSHJ P,CREINT
;; EMIT (ADD) ;ADD STK,[XWD SIZ,SIZ]
HRL C,D ;USE STACK # AS DISPL
EMIT (<SKIPL USADDR+NORLC+NOUSAC>) ;SKIPL STK
HRL C,PCNT ;EMIT INSTR TO CAUSE PDLOV.
EXCH C,LIBTAB+R$PDLOV ;FIXUP
EMIT (<JSP USER,NOUSAC!USADDR>)
BLTADN: POP P,A ;RESTORE STACK
POP P,PNT ;GET THIS BACK -- NOT IMPORTANT
MOVEI C,0 ;ZERO DISPL
EMIT (<BLT RTEMP,NOUSAC!USADDR!NORLC!USX>);BLT RTEMP,(STK)
POPJ P,
;;%DN% ↑
COMMENT⊗
DSCR MKSEMT
DES EMITS CODE TO BUILD ONE FHQ MSCP
PARM PNT2 POINTS AT FIRST PROC SEMBLK
SID MANGLES A,B,C,D,PNT,LPSA,TEMP
⊗
MKSEMT: PUSH P,FF ;SAVE IT
HRLI C,RF
EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>); PUSH P,F
MOVE B,CDLEV ;IF PARENT IS GLOBAL, NO LOOP
SOJG B,SLNKIT
HRRZ A,$VAL(PNT2) ;A pnts to PD SEMBLK
HLRZ PNT,%TLINK(A) ;PNT ptr to PDA SEMBLK
CAIE PNT,0 ;HAVE WE ONE?
JRST PPDAW ;YES
GETBLK ;NO--GET ONE
MOVE PNT,LPSA ;SET PNT TO THIS ONE
HRLM A,%TLINK(PNT) ;LNK BACK
HRLM PNT,%TLINK(A) ;AND FWD
;;# # (1 OF 2) BY JFR THE JSFIX WAS MISSING
PPDAW: EMIT (<PUSH RP,NOUSAC!JSFIX>) ;PUSH P,[PDA,0]
;;# #
JRST MKSSS ;GO DO STRING STUFF
SLNKIT: PUSHJ P,GETAN0 ;GET AC FOR LOOP
HRLI C,RF
EMIT (<SKIPA, USADDR!NORLC>);SKIPA AC,F
HRL D,D ;USE AS INDEX
HRLI C,1
EMIT (<MOVE USX!USADDR!NORLC>) ;MOVE AC,1(AC)
HRLI C,1
EMIT (<HLRZ RTEMP,NOUSAC!USX!USADDR!NORLC>); HRLZ TEMP,1(AC)
HLRZ PNT,%TLINK(PNT2) ;2ND PROC SEMBLK
HRRZ PNT,%SAVET(PNT) ;PARENT PROC
HRRZ PNT,$VAL(PNT) ;POINT AT PARENTS PD SEMBLK
EMIT (<CAIE RTEMP,NOUSAC!JSFIX>);
HRLZ C,PCNT
SUB C,[XWD 3,0]
EMIT (<JRST 0,NOUSAC!USADDR>);JRST .-3
HRRZ PNT,$VAL(PNT2) ;PNT2 ptr to PD SEMBLK
;;# # (2 OF 2) BY JFR THE JSFIX WAS MISSING
EMIT (<HRLI JSFIX>) ;HRL AC,PDA
;;# #
HRL C,D
EMIT (<PUSH RP,USADDR!NOUSAC!NORLC>);PUSH P,AC
COMMENT⊗
NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
⊗
;;#VU# JFR 11-21-75 CANT USE THIS INFO BECAUSE APPLY MIGHT JUMP INTO MIDDLE
;; AND THE REGISTER WOULD BE INVALID
;; MOVE B,CDLEV ;INTERNAL LEVEL
;; SUBI B,1 ;DADDY
;; PUSHJ P,DISBLK ;LPSA ptr to DISPLAY SEMBLK
;; HRRM D,DISTAB(B) ;UPDATE DISTAB
;;#VU# ↑
MKSSS: HRLI C,RSP
EMIT (<PUSH RP,USADDR!NORLC!NOUSAC>) ;PUSH P,SP
HRRZ PNT,$VAL(PNT2) ;MY PD SEMBLK
HRRZ A,PCNT ;PCNT AFTER MKSEMT
HRLM A,$ACNO(PNT) ;SAVED IN PD SEMBLK
POP P,FF
POPJ P,
COMMENT ⊗
DSCR SETF
DIS EMITS CODE TO SET UP NEW RF
PARM SAME AS MKSEMT
SID DITTO
⊗
SETF: PUSH P,FF
HRRI C,-2 ;WILL BE -2(P) FOR E PART
SKIPE RECSW ;UNLESS IT WAS RECURSIVE
MOVN C,ASDIS
HRLZ C,C ;FOR ADDRESS PART
EMIT (<HRRZI RF,NOUSAC!NORLC!USADDR(RP)>); HRRZI RF,-2(P)
POP P,FF
POPJ P,
COMMENT ⊗ TWPR1, TWPR2 -- Procedure Syntax Twiddlers⊗
DSCR TWPR1, TWPR2
PRO TWPR1, TWPR2
DES
at IDL: PDEC @IDL @I ) drarrow PDEC EXEC INTID ENDDEC TWPR2 SCAN
¬PD1 # Q0
at PD0: PDEC @I ; drarrow PDEC ; EXEC PRDEC TWPR1 ¬PD1 #Q0
⊗
↑TWPR2: MOVE PNT,GENRIG
MOVEI A,0 ;RESULTS TO PARRIG
JRST TWPR
↑TWPR1: MOVE PNT,GENRIG+1
MOVEI A,1
TWPR: PUSHJ P,GETAD
MOVE TEMP,%PDNO ;IF FORWARD, PARSER WILL LOOK FOR NO
TRNE TBITS,FORWRD ; PROCEDURE BODY
MOVEM TEMP,PARRIG(A) ;MODIFIED SYNTACTIC ENTRY
POPJ P,
SUBTTL Procedure Calls
COMMENT ⊗RDYCAL -- Prepare to Call Procedure⊗
DSCR RDYCAL
PRO RDYCAL
DES
@CALL SG drarrow @CALL SG EXEC RDYCAL ¬
Prepare for a procedure call.
A block needs to be prepared to hold information about the
call, because PROC(a,PROC(b)) would otherwise
cause awful confusion. The block contains:
1. In %TLINK, ptr to procedure semantics
2. In %TBUCK, ptr to next formal parameter definition
3. In $ADR, initial Qstack pointer for FTRPRM.
4. In $VAL, SDEPTH,,0. These (the stack counts) will be restored after the call.
The reason that ADEPTH cannot be saved has to do with the way LEAP
stacks things one too late. In other words, when a fucntion call is
seen, the ADEPTH count is really one too low, and all hell will break
loose if the procedure caller merely restores things. So it must keep
explicit count of what has happened.
The preparation of this block constitutes preparation for
the procedure call.
⊗
↑RDYCAL:
GETBLK (GENRIG)
JRST RDYCL
↑RDYCL1:
GETBLK (GENRIG+1) ;LPSA pnts to NEW BLOCK
RDYCL:
;; #LJ# ALL LEAP ARGS MUST REALLY BE STACKED BEFORE PROCEDURE CALL
PUSH P,LPSA ;SAVE LPSA OVER OKSTACK
PUSHJ P,OKSTAC ;MAKE SURE EVERYTHING IS STACKED THAT SHOULD BE
POP P,LPSA ;RESTORE LPSA
GETSEM (1) ;PNT ptr to SEMANTICS OF PROCEDURE
TLNE FF,LPPROG ;FOREACH IN PROGRESS?
TLNN TBITS,MPBIND ;AND THIS A MATCHING PROCEDURE?
JRST NOMPRO
PUSH P,PNT ;SAVE IT
PUSH P,LPSA ;IT ALSO
PUSHJ P,CHKSAT ;POP SATISFIERS INTO CORE IF NECESSARY
MOVEI A,0
PUSHJ P,CREINT
GENMOV (STACK,0) ;RESERVE A PLACE FOR ITEM PARAM TO SPROUT
POP P,LPSA
POP P,PNT
NOMPRO:
GLOC <
SKIPN MESFLG ;IS THIS A MESSAGE PROCEDURE ?
JRST NOMESQ ;NOPE
SETZM MESFLG ;RESET THE FLAG.
TLO SBITS,LPFREE ;THIS IS HOW WE TELL EVERYONE.
TLNN TBITS,MESSAGE
ERR <MESSAGE: REQUIRES MESSAGE PROCEDURE>,1
MOVEM SBITS,$SBITS(PNT);
NOMESQ:
>;GLOC
MOVEM TBITS,$TBITS(LPSA)
MOVEM SBITS,$SBITS(LPSA) ;COPY THESE
HRLM PNT,%TLINK(LPSA)
EXCH PNT,LPSA
TLNE TBITS,OWN ;BUILT-IN FUNCTION?
JRST BLTN ; YES, GO SET UP BYTE POINTER
LEFT ,%TLINK,LPSERR ;SECOND BLOCK OF PROC
LEFT (,%TLINK) ;ptr to FIRST PARAM OR NIL
HRRM LPSA,%TBUCK(PNT)
QCAL: QPUSH (FTRPRM) ;MAKE SURE STACK IS
QPOP (FTRPRM) ;INITIALIZED
MOVE TEMP,FTRPRM
MOVEM TEMP,$ADR(PNT) ;SAVE QSTACK POINTER
; lh of $VAL used to collect the number of string elements to be removed
; after the call -- rh is used for non-string elements.
;*-* HRLZ TEMP,SDEPTH
;*-* MOVEM TEMP,$VAL(PNT) ;SAVE SDEPTH,,0
GLOC <
TLNN SBITS,LPFREE ;IF A MESSAGE PROCEDURE, THEN
POPJ P, ;
XCALL <.MES1> ;PREPARE FOR THE CALLS.
>;GLOC
POPJ P,
BLTN: MOVEI TEMP,$SBITS+2(LPSA)
HRLI TEMP,440600 ;POINT 6,FIRST PARAM WORD
MOVEM TEMP,$VAL2(PNT) ;STORE FOR PARAM DESCRIPTOR RETRIEVAL
JRST QCAL ;FINISH UP
;MESSAGE PROCEDURE STARTER.
↑MESCL:
GLOC <
SETOM MESFLG ;NEXT FCALL IS A MESSAGE.
>;GLOC
NOGLOC <
ERR <This compiler will not handle MESSAGE PROCEDURES>,1
>;NOGLOC
POPJ P,
COMMENT ⊗ Describe CALARG⊗
DSCR CALARG
PRO CALARG
DES
at SID: IPR SG drarrow S SG EXEC ISUCL1 ¬S9
at EE2: PCALL @E ) drarrow S EXEC CALARG ISUCAL SCAN ¬S9
FCALL @E ) drarrow P EXEC CALARG ISUCAL TYPPRO SCAN ¬XID
@CALL @E , drarrow @CALL EXEC CALARG ¬EX0
IPR SG drarrow P SG EXEC ISUCL1 TYPR1 ¬XID
Generate parameter calls, issue procedure calls
A. Parameter calls
Several things have to happen here:
1. REFERENCE or VALUE determines whether an address or a
value will be "PUSH"ed. For reference parameters,
certain things are illegal (i.e. expressions, procedure
executions) unless we are issuing a FORTRAN call. Procedures
with no parameters must be called unless the formal is a
(reference, non-FORTRAN) procedure. The address word (with
types) is created (if possible) for reference
parameters. A reference parameter called by reference is a special
case.
2. A destination must be determined. For FORTRAN calls, the
semantics of the created (address) word is pushed into
a compile time "buffer" Qstack. For others, the
thing is stacked appropriately on the P or SP stack
(code is issued).
⊗
COMMENT ⊗ CALARG -- Pass a Parameter⊗
TOOMNY: ERR <TOO MANY ARGUMENTS SPECIFIED TO PROCEDURE>,1
;;#GW# 5-11-72 DCS (1-4) AVOID CALLING AT RUNTIME WITH TOO MANY PARAMS
TLNN TBITS,CONOK ;TRYING TO CALL AT COMPILE TIME?
JRST SAMADR ;NO
TLO TBITS,400000 ;SOMETHING SILLY -- DON'T DO IT.
MOVEM TBITS,(SP) ;UPDATE
JRST SAMADR
;;#GW# (1-4)
↑CALARG: PUSH P,SP ;GOOD SAFE AC
PUSH P,ADEPTH ;THIS IS FOR COMPARING PURPOSES.... SEE BELOW
GETSEM (2) ;SEMANTICS OF PROCEDURE CALL BLOCK
MOVE SP,PNT ;SAVE HERE
TLNE TBITS,ANYTYP ;IF ON, ASSUME REFERENCE, TYPE OK
JRST SAMADR
TLNE TBITS,OWN ;BUILT-IN PROCEDURE?
JRST [ILDB TBITS2,$VAL2(PNT) ; YES, GET FORMAL DESCRIPTION
JUMPE TBITS2,TOOMNY ; TOO MANY ARGUMENTS SUPPLIED
TRZ TBITS2,40 ; TURN OFF DEFAULTABLE BIT
MOVE TBITS2,BLTTBL(TBITS2)
JRST BLTBAK ;CONTINUE AFTER SIMILAR BRANCH
]
HRRZ PNT2,%TLINK(SP) ;PNT2 pnts to NEXT FORMAL PARAM DESCR
JUMPE PNT2,[TRNN TBITS,FORTRAN ;FORTRAN CALL?
JRST TOOMNY ;NO -- TO MANY ARGS CITED.
SETOM TBITS2 ;FLAG AS DON'T CONVERT
JRST FTRARG] ;ELSE GO AWAY.
HRRZ LPSA,%RVARB(PNT2) ;ptr to NEXT FORMAL PARAM AFTER THIS
HRRM LPSA,%TBUCK(SP) ;STORE POINTER TO NEXT IN CALL BLOCK
MOVE TBITS2,$TBITS(PNT2) ;ALL THAT'S IMPORTANT
BLTBAK: TRNE TBITS,FORTRAN ;FORTRAN CALL?
JRST FTRARG ; YES
GETSEM (1) ;SEMANTICS OF ACTUAL TO PNT GROUP
REC <
TRNE TBITS2,PNTVAR ;CHECK RECORD CLASSES HERE
TDNE TBITS2,[XWD SBSCRP,ITEM!ITMVAR!SHORT]
;DONT CHECK ARRAYS AND
;NEVER CHECK ITEMISH STUFF(UNLESS CHECKED?)
JRST BLTB.1
PUSH P,LPSA ;PARANOIA
PUSH P,PNT2 ;
;;#TV# RHT 1-22-75 DON'T CHECK IF RUNTIME ROUTINE
MOVE LPSA,$TBITS(SP) ;CHECK PROCEDURE SEMANTICS
TLNE LPSA,OWN ;IF RUNTIME ROUT, CLASS IS ANY
JRST BLTB.Z ;IT IS
;;#TV# ↑
HLRZ PNT2,$ACNO(PNT2);CLASS OF FORMAL
BLTB.X: HLRZ LPSA,$ACNO(PNT) ;CLASS OF ACTUAL
BLTB.Y: PUSHJ P,SUBFOK
ERR <CLASS DISAGREEMENT IN ACTUAL-FORMAL RECORD PAIR>,1
BLTB.Z: POP P,PNT2
POP P,LPSA
BLTB.1:
>;REC
TLNE TBITS2,REFRNC ;BY REFERENCE?
JRST REFARG ; YOU BETCHUM
TLNE TBITS2,MPBIND ;A FORMAL ? ITEMVAR
JRST MPPARM ;YES
; ***** BUG TRAP
TLNN TBITS2,VALUE ;TEST UNLIKELY CASE
ERR <DRYROT -- CALARG>,1
; VALUE PARAMETER
TLNN SBITS,LPFRCH!FREEBD
JRST VALPAR
TLNE SBITS,LPFREE
ERR <UNBOUND LOCAL AS PARAMETER TO PROCEDURE>,1
PUSHJ P,CHKSAT ;POP SATISFIERS INTO CORE IF NECESARY
VALPAR: TLNE TBITS,SBSCRP ;MAKE A TEST
ERR <ARRAYS BY VALUE NOT IN>,1
PUSH P,TBITS2 ;SAVE FORMAL TYPE BITS
TRNE TBITS,PROCED ;IF VALUE PROCEDURE, NO PARAMS,
PUSHJ P,CALNPR ; CALL IT NOW
OKPRM: POP P,B ;TYPE OF FORMAL
TLNN TBITS,FORMAL!SBSCRP ;FOR LEAPISH CONSTRUCTS.
TRNN TBITS,ITEM
JRST GMV
TRNN B,ITEM!ITMVAR ;TARGET TYPE
ERR <ITEM TYPE MISMATCH>,1 ;BLOW
SKIPE PNT,$VAL2(PNT) ;PLACE WHERE ITEM NUMBER IS STORED.
PUSHJ P,GETAD ;AND GET HIS BITS.
HRRI FF,POSIT
JRST GMV2+1
GMV: TRNE TBITS,ITEM!ITMVAR
JRST GMV2
TRNE TBITS,LSTBIT
JRST [TRNN B,LSTBIT ;BOTH LISTS, NO WORRY
ERR <WARNING-LIST EXPR. COERCED TO SET EXPR>,1
JRST .+1]
GMV2:
HRRI FF,INSIST!POSIT
;;# # DCS 2-29-72 CALL F(CONST,...) AT COMPILE TIME
MOVE TBITS2,$TBITS(SP) ;PROC CALL BLOCK BITS
TLNE TBITS2,CONOK ;STILL OK?
TLNN TBITS,CNST ; ALSO NO USE IF THIS NOT CONST
JRST STRET ;NO
GENMOV (CONV) ;MAKE SURE CONVERTED
HRRI FF,0 ;IN CASE NOT CONST
TLNN TBITS,CNST ;CONST OF RIGHT TYPE?
JRST STRET ;NO
; STILL CONOK, SAVE CONST
QPUSH (FTRPRM,PNT) ;SAVE THE SEMBLK
POP P,ADEPTH ;NO CHANGE TODAY
POP P,SP ;GET STACK BACK
POPJ P, ;DONE RIGHT NOW
;;# #
STRET: PUSHJ P,CONCHK ;STACK PREV CONSTS
REC <
TRNE TBITS,PNTVAR ;A RECORD POINTER??
TRNE TBITS,777777-(PNTVAR!GLOBL)
JRST NOTRCD ;NOPE
NORGC <
GENMOV (GET,MRK!INDX) ;YEP,HAVE TO BUMP REF CNT. GET WILL DO IT
;NOTE: IF THIS ALREADY WAS A REGULAR TEMP
;THEN THE GET WILL NOT BUMP THE COUNT AGAIN
>;NORGC
RGC <
TLNE SBITS,INAC ;IS THE THING INAC
JRST STRT.1 ;YES
;;#XT# ! MUST ALLOW FOR UP-LEVEL ADDRESSING
GENMOV (GET)
STRT.1: HRRZ D,$ACNO(PNT) ;FIND OUT WHAT AC ITS IN
PUSHJ P,GETRCT ;GET US AN AVAILABLE RECORD CORTMP
HRRZ TEMP,$ACNO(SP) ;SP POINTS AT PROC CALL SEM. (UGH!!)
HRRM TEMP,%TLINK(LPSA) ;LINK ONTO CHAIN
HRRM LPSA,$ACNO(SP) ;LIKE SO
PUSH P,PNT ;SAVE THE THING WE ARE GOING TO PUSH
MOVE PNT,LPSA ;NOW MOVEM INTO THIS TEMP
EMIT (<MOVEM>) ;
POP P,PNT ;SO THAT THE PUSH EVENTUALLY WINS
>;RGC
NOTRCD:
>;REC
GENMOV (STACK) ;DO THE PUSH.
MOVEI PNT,0 ;SO WON'T REMOP TWICE
MOVSI TEMP,2 ;Keep track of the number of string
;;#HM# JRL 5-31-72 AVOID DRYROT BY STRING ARGS TO MESSAGE PROCEDURE
MOVE SBITS,$SBITS(SP) ;WILL TELL IF A MESSAGE PROC. CALL
;;#HR# JRL 6-14-72 A STRING ITEM IS NOT A STRING
TRNE TBITS,ITEM!ITMVAR ;TURN OFF STRING BIT FOR ITEMS
TRZ TBITS,STRING
;;#HR#
TRNE TBITS,STRING ; words which will adjust SDEPTH
TLNE SBITS,LPFREE ;A MESSAGE PROCEDURE
JRST CALRET ;If message pro, or not string no sdepth change
ADDM TEMP,$VAL(SP) ; when call is finished.
;; #HM#
JRST CALRET ;DONE ALREADY
CONCHK: PUSH P,B
;; #MA (1 OF 4) ! SAVE FF OVER CALL
PUSH P,FF
MOVE TEMP,$TBITS(SP) ;CONOK bit on in this Semblk (PCALL
TLZN TEMP,CONOK ; block) if calling runtime which can
;; #MA (2 OF 4) !
JRST FBPOPJ ; be evaled at comp. time, and all prev
MOVEM TEMP,$TBITS(SP) ; args were const -- but this arg is
MOVE B,$ADR(SP) ; non-const, so must recover.
CAMN B,FTRPRM ;If there were no previous constant
;; #MA (3 OF 4) !
JRST FBPOPJ ; args, there is nothing left to do.
PUSH P,PNT ;Now issue stack code for each arg
CONCAL: QTAKE (FTRPRM) ; previously saved (types already
JRST CONDUN ; matched up before saving).
MOVE PNT,A
GENMOV (STACK,GETD!REM)
MOVSI TEMP,2 ;Update the ADEPTH or SDEPTH count in
TRNN TBITS,STRING ; Pcall Semblk -- will be used to readjust
AOSA $VAL(SP) ; these variables when call finished.
ADDM TEMP,$VAL(SP)
JRST CONCAL
CONDUN: MOVE TEMP,$ADR(SP) ;No REF args were handled, our part of
MOVEM TEMP,FTRPRM ; this stack had only consts, can remove.
POP P,PNT ;Now the state of things is as if the
PUSHJ P,GETAD ; stack code had gone out the first time.
;; #MA (4 OF 4) ! RESTORE FF
FBPOPJ: POP P,FF
BPOPJ: POP P,B
POPJ P,
MPPARM: ;BINDING ITEMVAR PARAMETER
TRNN TBITS,ITEM!ITMVAR ;BETTER BE ITEM TYPE
ERR <PARM TO ? ITEMVAR NOT ITEM EXPRESSION>,1
TLNE PNT,FBIND!QBIND ;IS IT BIND ITEMVAR?
JRST PASREF ;WILL PASS BY REFERENCE
TLNE SBITS,LPFRCH!FREEBD
TLNN SBITS,LPFREE ;STILL FREE WITHIN FOREACH?
JRST VALPAR ;NO TREAT AS VALUE PARAMETER
NTPARM: QPUSH (MPQSTK,PNT) ;PUT THIS ON PARM LIST
; AT THIS POINT GENERATE APPROPRIATE LPCALL FOR POTUNB IF NECESSARY.
;;#TJ# ! USED TO BE TBITS
TLNE SBITS,FREEBD
JRST [MOVE PNT,$VAL2(PNT) ;GET LOCAL NUMBER
GENMOV (STACK,0)
LPCALL (STKQPR) ;INTERPRETIVE CALL TO SEE IF BOUND
JRST CALRET]
PASREF: PUSH P,PNT ;SAV LH ACTUALLY
GENMOV (INCOR,0) ;MAKE SURE NOT IN AC
HRLI PNT,20 ;WANT INDIRECT BIT
SETOM MPFLAG ;TO TELL THAT WE WANT TYPE BITS
PUSHJ P,FTRADR ;GET ADCON
GENMOV (STACK,0) ;STACK IT
SETZM MPFLAG
POP P,PNT
TLNN PNT,QBIND
JRST CALRET
HRLZI D,RP ;WILL NOW LOAD VAL FROM STACK
EMIT <MOVEI TAC1,INDRCT!NOUSAC!NOADDR!USX> ; GEN MOVEI TAC1,@(P)
HRLI C,UNBND ;FOR COMPARE WITH UNBOUND
EMIT <CAIE TAC1,NOUSAC!USADDR!NORLC>
EMIT <MOVEM TAC1,NOUSAC!NOADDR!USX>
JRST CALRET
; FORTRAN ARGUMENT -- ASSURE VALID TYPE
FTRARG:
GETSEM (1)
TLNE TBITS,SBSCRP
ERR <DON'T PASS ARRAYS TO FORTRAN (YET)>,1
TRNE TBITS,PROCED ;PROCEDURES MUST BE EVALUATED
PUSHJ P,CALNPR ; CALL WITH NO PARAMS
HRRI FF,INSIST!POSIT
SKIPG B,TBITS2 ;THIS IS THE TYPE WE HOPE FOR
TRC FF,INSIST!ARITH ;NO TYPE SPECIFIED -- JUST GET ARITH.
TLNE TBITS,CNST ;PROTECT CONSTANTS BY MOVING THEM.
JRST CNGET
GENMOV (CONV)
JRST MAKADR ;GO MAKE ADDRESS CONSTANT
CNGET: TRO FF,MRK
GENMOV (GET)
JRST MAKADR
REFARG: PUSHJ P,CONCHK ;STACK PREV CONSTANTS
TRNE TBITS2,PROCED ;IF FORMAL ¬ PROCEDURE,
JRST CHKEXP
TRNE TBITS,PROCED ;AND ACTUAL IS ONE, ERROR
PUSHJ P,CALNPR ;MAKE IT AN EXPRESSION TO PASS BY REFERENCE
CHKEXP:
; #HZ# JRL 6-27-72 TEST SBSCRP BIT BEFORE ALL OTHERS
TLNE TBITS,SBSCRP
JRST CKTYP
TRNE TBITS,ITEM
ERR <DO NOT PASS ITEMS BY REFERENCE>,1
TRNE TBITS2,LSTBIT ;LIST FORMAL?
JRST [TRNE TBITS,LSTBIT; AN ACTUAL LIST?
JRST .+1 ;YES
MOVE B,SET!LSTBIT
JRST RTYPER]
TLNE SBITS,LPFRCH!FREEBD
ERR <FOREACH LOCAL AS REFERENCE PARAMETER>,1
; #HZ#
TLNN SBITS,ARTEMP!STTEMP ;EXPRESSION?
JRST CKTYP ;NO
TLNE SBITS,FIXARR ;FIXED CALCULATED ARRAY THING?
JRST CKTYP ; YES, DON'T WORRY
TLNN SBITS,INDXED ;OK IF CALCULATED SUBSCRIPT
JRST [TRNN TBITS2,STRING ;DON'T ALLOW STRING EXP BY REF
ERR <WARNING: EXPRESSION BY REFERENCE;
WILL WORK BUT INACCESSABLE AFTER CALL>,1
STREXP: TRNE TBITS2,STRING
ERR <NO STRING EXPRESSIONS BY REFERENCE>,1
GENMOV (INCOR)
QPUSH (FTRPRM,PNT) ;SAVE FOR LATER REMOPING
JRST .+1] ;GO CHECK TYPES
CKTYP:
;;%AE% RHT ALLOW TYPED ITEMVARS THROUGH TO ITEMVAR FORMALS
TRNE TBITS2,ITMVAR ;ITEMVAR FORMAL
TRNE TBITS2,¬<ITMVAR+PROCED> ;ANYTHING ELSE TOO
JRST .+2 ;NO CHANGE
TRZ TBITS,¬<ITMVAR+PROCED> ;TURN OFF THE BAD GUYS
;;%AE%
TRNA TBITS,PROCED ;SPECIAL CHECK
JRST [PUSH P,TBITS2
HRRZ TEMP,GENLEF+1 ;GET THE ARGUMENT PROCEDURE
TLNE TBITS,OWN
JRST CKTYPO ;EVEN SPECIALER
CKTYP0: HRRZ TEMP,%RVARB(TEMP) ;GET PARMS TO PARM PROC
JUMPE TEMP,CKTYP2 ;DONE
HRRZ TBITS2,$TBITS(TEMP) ;GET BITS
TLNN TBITS2,REFRNC ;PARMS OF PRAM PROC MUST BE REF.
ERR <PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
JRST CKTYP0
CKTYPO: MOVEI TEMP,$ACNO(TEMP) ;MAKING BYTE POINTER
HRLI TEMP,440600 ;POINT 6,FIRST PARM WORD
CKTYP1: ILDB TBITS2,TEMP ;GET BITS
;;#??# RHT WHAT IS GOING ON HERE?????
JUMPE TBITS,CKTYP2 ;DONE
TLNN TBITS,REFRNC ;
ERR <PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
JRST CKTYP1
CKTYP2: POP P,TBITS2
JRST .+1 ]
;; \UR#12\ NEED ITEMVAR ACTUAL FOR ITEMVAR FORMAL
IFN 0,< ; THIS FIX SCREWS UP ARRYIN,ARRBLT,ARROUT. SO REMOVE FOR NOW
;; MUST INSIST THAT ITEMVAR FORMAL RECEIVE ITEMVAR ACTUAL
TRNE TBITS2,ITMVAR
JRST [ TRNN TBITS,ITMVAR
ERR <ITEMVAR FORMAL NEEDS ITEMVAR ACTUAL>,1
JRST .+1 ]
;; MUST INSIST THAT CONTEXT FORMAL HAVE CONTEXT ACTUAL
TRNE TBITS2,SET
JRST [ TRNN TBITS,SET
JRST RTYPER
TRNN TBITS2,FLOTNG
JRST .+1
TRNN TBITS,FLOTNG
ERR <CONTEXT FORMAL NEEDS CONTEXT ACTUAL PARAM>,1
JRST .+1]
;; END OF PATCH
>;IFN 0
;; \UR#12\
MOVE B,TBITS ;ALGORITHM IS TO MAKE SURE THAT ALL BITS
AND B,[XWD SBSCRP,ALTYPS] ;ON IN ACTUAL ARE ON IN FORMAL.
SETCM TEMP,TBITS2 ;THIS ALLOWS ARRINFO AND FRIENDS TO HAVE
TLNE TBITS2,SBSCRP ;IF FORMAL REQUIRES ARRAY, THEN MAKE SURE IT IS
TLNE TBITS,SBSCRP
TDNE B,TEMP ;ANY TYPE ARRAYS PASSED TO THEM.
RTYPER: JRST [TERPRI <WARNING: TYPE MISMATCH FOR REFERENCE CALL>
TERPRI <CONVERTED EXPRESSION WILL BE PASSED BY REFERENCE>
ERR <ORIGINAL VARIABLE WILL NOT BE ALTERED BY PROCEDURE>,1
MOVE B,TBITS2
GENMOV (CONV,INSIST) ;MAKE TYPE CONVERSION
MOVE TBITS2,TBITS ;DON'T LET IT HAPPEN AGAIN!
JRST STREXP]
JRST MAKADR ;FINISH UP
; CREATE FORTRAN-LIKE TYPE BITS FOR AC FIELD
SAMADR: GETSEM (1) ;NOBODY ELSE GOT ACTUAL'S SEMANTICS
MAKADR: MOVE TBITS2,$TBITS(SP) ;GET PROC BITS BACK
TLNE SBITS,INDXED ;NO NEED TO STORE INDXED THINGS
JRST LATER ; BECAUSE DYNAMAK AND FRIENDS WILL
GENMOV (INCOR) ;MAKE SURE ARG IS IN CORE.
LATER:
TRNE TBITS2,FORTRAN ;IF HERE AND FORTRAN, WE DEFINITELY
JRST .+3 ;WANT TO STAY HERE DAMMMMMIT
TLNE TBITS,REFRNC
JRST REFREF ;REF CALLED BY REF (SPCL CASE)
;;%DT% FORTRAN-10 WANTS 2 FOR INTEGR, 4 FOR FLOTNG
TRNN TBITS2,FORTRAN
JRST .+3 ;NOT FORTRAN
SKIPE TEMP,ASWITCH
TRNN TEMP,ASWF10
TDZA TEMP,TEMP ;NOT FORTRAN-10, START AT ZERO
MOVEI TEMP,2 ;FORTRAN-10, ADD 2
;;%DT% ↑
TRNE TBITS,FLOTNG ;0 FOR INTEGR, 2 FOR FLOATING,
ADDI TEMP,2
TLNE TBITS,SBSCRP ;8 + OTHERS FOR ARRAYS
ADDI TEMP,=8
LSH TEMP,5 ;TO AC POSITION
HRL PNT,TEMP ;TO AC AREA
; PNT NOW CONTAINS SEMANTICS OF REF VBL IN LH, TYPES IN RH
TRNE TBITS2,FORTRAN ;CALLING FORTRAN?
JRST FTRSAV ;YES, JUST SAVE ADCON SEMANTICS
TLNN TBITS,SBSCRP ;STACK VBL ITSELF IF SBSCRP
PUSHJ P,ADRINS ;GET ptr to ADCON IN PNT, ETC.
GENMOV (STACK,0) ;STACK IT
JRST CALRET
FTRSAV: PUSHJ P,FTRADR ;GET (UNIQUE) ADCON SEMANTICS
QPUSH (FTRPRM,PNT) ;SAVE SEMANTICS TILL LATER
JUMPL PNT,[POP P,A
POP P,SP
POPJ P,]
JRST CALRET
REFREF: GENMOV (STACK,ADDR) ;JUST STACK IT AGAIN (REF BY REF)
CALRET:
MOVE SP,GENLEF+2 ;SINCE TOTAL USES THE DAMNED THING.
POP P,A ;OLD ADEPTH.
GLOC <
MOVE SBITS,$SBITS(SP) ;SBITS FOR PROCEDURE.
TLNN SBITS,LPFREE ;IF A MESSAGE PROCEDURE IS BEING ISSUED.
JRST CAL00 ;NO
MOVE TBITS2,$TBITS(PNT2) ;DESTROYED IF A REFERENCE.
TRNE TBITS2,PROCED!LABEL ;THESE NOT ALLOWED.
ERR <MESSAGE: INVALID PARAMETER LIST MEMBER>,1
TRNE TBITS2,STRING ;GODDAMN
TLNE TBITS2,REFRNC
JRST .+3 ;FIGURE OUT WHICH STACK TO SUBTRACT
SOS SDEPTH
SOSA SDEPTH
SOS ADEPTH ;ALL OVER.
HRL C,TBITS2 ;GET THE TBITS WORD IN TAC1
EMIT (<MOVEI TAC1,USADDR!NOUSAC!NORLC>)
HLL C,TBITS2
EMIT (<HRLI TAC1,USADDR!NOUSAC!NORLC>)
XCALL <.MES2> ;AND PROCESS THE PARAM.
JRST NOADJ ;DO NOT INDEX COUNTS. -- OTHERWISE DOOM.
CAL00:
>;GLOC
CAME A,ADEPTH ;SAME AS NOW (WAS THERE A PUSH DONE??)
AOS $VAL(SP) ;NO -- UPDATE COUNTS.
NOADJ: POP P,SP ;RESTORE STACK
JRSP REMOP ;REMOVE TEMP ARGS,RETURN
↑CALNPR: PUSH P,GENRIG ;SINCE ISUCL1 DESTROYS IT.
MOVEM PNT,GENLEF+1 ;SIMULATE A CALL TO RDYCAL
PUSHJ P,RDYCL1 ;AS THE PARSER WOULD DO IT
MOVEW GENLEF+1,GENRIG+1 ;RESULTS BACK TO LEFT SIDE
PUSHJ P,ISUCL1 ;CALL THE PROCEDURE
MOVE PNT,GENRIG+1
POP P,GENRIG ;RESTORE THE BLESSED CELL (IT ONLY POINTS TO PROC).
JRST GETAD ;LEAVE ITS SEMANTICS IN PNT, ETC.
COMMENT ⊗ ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
Address constant blocks have fixup information for
address constants necessary for procedure calls. The
constants are of the form:
TYP(fortran),,address, where TYP is:
0 for integer
2 for floating
8 + others for arrays
An ADCON block uses %RVARB to link to the ADRTAB ring.
The %TLINK field indicates the intity whose AD
is being CONned. The type is inserted in the left
half of $ADR -- fixups for the ADCON go in $ADR(rh).
These constants will be output after space is
allocated for the associated variables, or at the
time of a FORTRAN call. For temps and those
blocks involved in a FORTRAN call, unique ADCON
blocks are assigned for each eventual word of code. For
others, fixups are chained via a search of the
ADCON list.
IN: PNT -- TYPE,,semantics of entry
OUT: PNT,TBITS,SBITS -- semantics of result
C(lh) -- old fixup
Call ADRINS for normal insertion, FTRADR for unicke ones
If FTRADR is called with MPFLAG non-zero the type bits,
in left half PNT will be inserted but otherwise FORTRAN-like
things won't happen (see DYNAMAK)
If MPFLAG is set the address of the array is considered to be
the address of the cell containing the descriptor. I don't
believe ADRINS is every called with an array except if MPFLAG
is set.
⊗
↑ADRINS: TLOA FF,FFTEMP ;CONDUCT A SEARCH
↑FTRADR: TLZ FF,FFTEMP ;DON'T
PUSHJ P,GETAD ;GET SEMANTICS OF AD TO BE CONNED
TRNE SBITS,DLFLDM ;IF A DISPLAY REG IS NEEDED
JRST DYNAMAK ;MUST DO DYNAMAK
;; #KD# ! RHT 11-13-72 FOLLOWING INSTR HAD SBITS MISSING
TLNE SBITS,CORTMP ;ALSO CHECK THE CASE OF TEMPS IN REC PRO
SKIPN RECSW ;
JRST .+2 ;
JRST DYNAMAK ;
NOREC <
TRNE TBITS,PNTVAR ;DON'T REALLY UNDERSTAND THESE YET
ERR <POINTER VARS MAY NOT BE CALLED BY REFERENCE>,1
>;NOREC
TLNE SBITS,FIXARR ;IF HAVE CALCULATED WHOLE INDEX THING,
JRST DYNAMAK ; GET IT WITH A MOVEI
TLNN TBITS,FORMAL ;IF ARG IS NOT IN FIXED LOC,
TLNE SBITS,INDXED
JRST DYNAMAK ; CREATE ADCON AT RUN TIME
TLNN FF,FFTEMP ;ALSO IF FORTRAN TYPE ADCON
JRST INSNEW ;JUST INSERT A NEW ONE
TLNE SBITS,ARTEMP ;DON'T SEARCH FOR TEMP MATCHES
JRST TEMLUK ; IN THE SAME WAY
TLNE TBITS,CNST ;ALSO CONSTANTS DONE DIFFERENTLY
JRST CONADD
SRCH: MOVE LPSA,ADRTAB ;ADDRESS CONSTANT "RING"
JUMPE LPSA,INSNEW ;NOTHING YET, MAKE SOMETHING
SRCLUP: HLRZ TEMP,%TLINK(LPSA) ;ptr to SEMANTICS OF THING
CAIN TEMP,(PNT) ;SAME STUFF?
JRST FOUND1 ;YES, FOUND ONE
LEFT ,%RVARB,INSNEW ;KEEP LOOKING
JRST SRCLUP
TEMLUK: TLNN SBITS,CORTMP ;MUST BE A CORTMP
ERR <DRYROT -- TEMLUK>
MOVE LPSA,ADRTAB ;SEARCH ADCON TABLE FOR SAME ID NO
JUMPE LPSA,INSNEW ;NONE FOR THIS TEMP YET
MOVE A,$PNAME(PNT) ;TEMP ID NO FOR THIS TEMP
TMLUUP: MOVE TEMP,$SBITS(LPSA)
TLNN TEMP,ARTEMP ;MUST BE TEMP OR DON'T LOOK
JRST LEFLUK
CAMN A,$PNAME(LPSA) ;SAME TEMP?
JRST GETADL ;YES, THIS IS THE RESULT
LEFLUK: LEFT ,%RVARB,INSNEW ;LOOP UNLESS YOU RUN OUT
JRST TMLUUP
FOUND1: HLLZ TEMP,$ADR(LPSA) ;MAKE SURE TYPE HASN'T CHANGED
HLR TEMP,PNT
TSC TEMP,TEMP ;SEE IF TYPE FROM ADCON IS SAME
SKIPN TEMP ; AS THAT COMING IN
JRST GETADL ;IT IS,DONE
INSNEW: GETBLK
;GET ANOTHER ONE
PUSHJ P,RNGADR ;ADD THIS ADCON TO ADRTAB
HLLM PNT,$ADR(LPSA) ;STORE TYPE
HRLM PNT,%TLINK(LPSA) ;AND SEMANTICS OF THING BEING ADCONNED
MOVEW (<$PNAME(LPSA)>,<$PNAME(PNT)>) ;TRANSFER ID NO IF ANY
MOVEI TEMP,INTEGR ;TYPE FOR ADCON ITSELF, IF NEEDED
MOVEM TEMP,$TBITS(LPSA)
MOVEM SBITS,$SBITS(LPSA) ;SAVE SBITS FOR ADCON TYPE DETERMINATION
HRR PNT,LPSA ;DO NOT CLOBBER LEFT HALF OF PNT.
JRST GETAD ;THAT'S IT.
CONADD: TRNE TBITS,STRING ;WILLING TO PASS ALL BUT STRING CONST
ERR (<NO STRING CONSTANTS BY REFERENCE>,1) ;BY REFERENCE
PUSH P,$VAL(PNT) ;SAVE FOR A MOMENT
PUSH P,$TBITS(PNT)
PUSHJ P,REMOP ;IN CASE IN AC
POP P,BITS
POP P,A
PUSHJ P,ADCINS ;SPECIAL ENTRY (UNIQUE)
JRST INSNEW ;MAKE ADCON FOR THIS UNIQUE CONSTANT
DYNAMAK:
MOVEM TBITS,TBSAVE ;SAVE SBITS
TLNE TBITS,SBSCRP ;AN ARRAY
TLZN TBITS,REFRNC ;TURN OFF REFERENCE BIT
CAIA
TLO TBITS,VALUE ;TURN ON VALUE BIT IF WAS REFRNC
MOVEM TBITS,$TBITS(PNT);
GENMOV (GET,ADDR!REM) ;WILL GET ADDRESS OF THING WITH A MOVEI
;IT ALL HAPPENS MAGICALLY
MOVE TBITS,TBSAVE
MOVEM TBITS,$TBITS(PNT)
HLLZ C,PNT ;TYPE BITS, USE AS ADDR FLD OF HRLI
PUSHJ P,MARKINT ;MARK AN INTEGER FOR KICKS.
TLNE FF,FFTEMP ;FORTRAN CALL REQUIRE THIS ADCON?
POPJ P, ;NO, LEAVE SEMANTICS FOR PUSH
JUMPN C,NDBITS ;ARE THERE NON-ZERO TYPE BITS
SKIPE MPFLAG ;IF NO BITS AND NOT FORTRAN
POPJ P, ;RETURN
NDBITS:
;;%DT%
SKIPN TEMP,MPFLAG ;DON'T CHANGE INSTR IF LEAP CALL: MPFLAG IS SETZM/SETOM
SKIPE TEMP,ASWITCH ;FORTRAN CALL, WHICH KIND?
TRNN TEMP,ASWF10 ;ALWAYS SKIPS IF LEAP
TLO C,(<JUMP>) ;F40 CALL PUTS NOOP HERE
EMIT (<HRLI USADDR+NORLC>) ;HRLI AC,TYPE*2↑5
SKIPE MPFLAG
POPJ P, ;IF REMEMBER OF MP RETURN NOW.
PUSHJ P,REMOP ;DON'T NEED SEMANTICS ANYMORE
PUSH P,TBITS ;JUST IN CASE
PUSH P,SBITS
MOVEI TBITS,INTEGR
PUSHJ P,GETCRTMP ;A CORETEMP FOR THE COMPUTED ADDRESS
MOVEI PNT,(LPSA)
EMIT (<MOVEM>) ;STORE THE ADDRESS
POP P,SBITS
POP P,TBITS
IOR PNT,C ;COPY BITS
TLO PNT,400000 ;AND MARK LH NEG
;;%DT% ↑
POPJ P,
COMMENT ⊗ ISUCAL -- Call the Procedure, Mark Resultant Type, etc.⊗
DSCR ISUCAL, ISUCL1
PRO ISUCAL ISUCL1
RES
PCALL @E ) drarrow S EXEC CALARG ISUCAL SCAN GO S9
FCALL @E ) drarrow P EXEC CALARG ISUCAL TYPPRO SCAN GO XID
IPR SG drarrow P SG EXEC ISUCL1 TYPR1 GO XID
⊗
↑ISUCAL:
SKIPA PNT,GENLEF+2 ;GET PROCEDURE
↑ISUCL1:
MOVE PNT,GENRIG+1 ; CALL BLOCK SEMANTICS
; (PLACED BY RDYCAL FOR ISUCL1)
ISSUE: PUSH P,$ADR(PNT) ;CONTAINS SAVED FTRPRM PTR.
PUSH P,$VAL(PNT) ;RESTORE DEPTHS
;BUT AFTER CALLING ALLSTO, ETC.
BICHK: MOVE TBITS2,$TBITS(PNT) ;NEED TO CHECK BUILT-IN
MOVE C,TBITS2 ;FOR CONST EVAL DON'T DO IT FLAG
TLNE TBITS2,OWN ; IS IT?
JRST [MOVE B,$VAL2(PNT) ;YES, GET NEXT PARAM DSCRPTR
ILDB TEMP,$VAL2(PNT) ; SO CAN RESTORE
JUMPE TEMP,OKCAL ;SHOULD BE 0 (NONE LEFT)
TRZN TEMP,40 ;DEFAULTABLE?
JRST ERCAL ;NO
MOVE TBITS,BLTTBL(TEMP);TBITS OF THIS ARG
TLNN TBITS,VALUE ;REF NEVER DEFAULTED
JRST ERCAL
PUSH P,PNT ;SAVE PNT
MOVEI A,0 ;COMMON NULL VALUE
MOVE PNT,UBSBLK ;
TRNE TBITS,ITMVAR ;ITEMVARS ARE SET TO NEC
JRST SFFPRM
TRNE TBITS,STRING ; A STRING GETS A NULL STRING
JRST NSTVP ;
PUSHJ P,CREINT ;
SFFPRM: MOVE TEMP,PNT ;
MOVE PNT,(P) ;THE PROCID
MOVEM B,$VAL2(PNT)
JRST PCA1 ;GO PUSH THE CONST ARG
NSTVP: PUSH P,BITS ;SAVE SOME CRUFT
PUSH SP,PNAME ;
PUSH SP,PNAME+1 ;
SETZM PNAME ;NULL
PUSHJ P,STRINS ;MAKE ONE
POP SP,PNAME+1 ;
POP SP,PNAME ;PUT EM BACK
POP P,BITS ;
JRST SFFPRM ;GO STACK IT
]
RIGHT PNT,%TBUCK,OKCAL ;MAKE SURE FORMAL LIST IS EMPTY
HRRZ TEMP,$VAL2(LPSA) ;GET DEFAULT VALUE , IF ANY
JUMPE TEMP,ERCAL ;YOU LOSE
PCA: PUSH P,PNT ;SAVE
PCA1: PUSH P,GENLEF+1 ;
PUSH P,GENLEF+2 ;
MOVEM TEMP,GENLEF+1 ;
MOVEM PNT,GENLEF+2 ;
;;#WL# JFR 3-16-76 BUMP REF CNT OF STRING DEFAULT PARAM SO REMOP WONT DRYROT
MOVEI PNT,(TEMP)
PUSHJ P,GETAD
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING
JRST .+2
AOS $VAL2(PNT)
;;#WL# ↑
PUSHJ P,CALARG ;OH, WHAT A DREADFUL THING TO DO
POP P,GENLEF+2 ;
POP P,GENLEF+1 ;
POP P,PNT ;PUT EM BACK THE WAY THEY WAS
;;#NH# RHT 7-25-73 1 OF 1 THE THINGS ON THE STACK WERE CHANGED BY CALARG
SUB P,X22
JRST ISSUE ;TRY AGAIN
;;#NH#
ERCAL: ERR <NOT ENOUGH PARAMETERS SUPPLIED TO PROCEDURE>,1
;;#GW#! 5-11-72 DCS (2-4) DON'T CALL AT COMPTIME IF WRONG NUMB. OF PARAMS
TLO C,400000 ;FLAG ERROR -- DON'T EVAL AT COMPILE TIME
NORGC <
OKCAL: HRRZ LPSA,PNT ;RELEASE CALL BLOCK,
HLRZ PNT,%TLINK(PNT) ; GET SEMANTICS OF PROC
>;NORGC
RGC <
OKCAL: PUSH P,PNT
HRRZ PNT,$ACNO(PNT) ;FETCH THE THINGS TO REMOP
JUMPE PNT,OKCA.1 ;NONE LEFT
OKCA.0: EMIT <SETZM NOUSAC> ;ZERO IT OUT
MOVE LPSA,PNT ;
HRRZ PNT,%TLINK(PNT) ;GET NEXT
PUSHJ P,REMOPL ;
JUMPN PNT,OKCA.0 ;LIKE SO
OKCA.1: POP P,LPSA ;FOR THE FREBLK
HLRZ PNT,%TLINK(LPSA) ;PROC CALL SEMANTICS
>;RGC
FREBLK
PUSHJ P,GETAD ; PNT, ETC. DESCRIBE PROC SEMANTICS
;;# # DCS 2-29-72 COMPILE-TIME CALL OF PROCEDURE
TLNN TBITS2,CONOK ;If CONOK on, all args were const, we call
JRST NC ; the procedure now, recording approp. const.
POP P,TEMP ;Any saved Depths are irrelevant now
EXCH SP,STPSAV ;Prepare stacks and pdlov-message information
MOVSS POVTAB+6 ; for the impending call.
MOVE B,(P) ;Fetch start of our part of stack, verify that
CAMN B,FTRPRM ; there were args, or quit.
JRST NA
NOWLUP: QTAKE (FTRPRM) ;Actually stack each constant value, then REMOP
JRST NA ; its representation. Choose the right stack.
MOVE PNT2,A
PUSHJ P,REMOP2
MOVE TBITS2,$TBITS(PNT2)
;;#GW#! 5-11-72 DCS (3-4) SEE JUST ABOVE
JUMPL C,NOWLUP ;DON'T DO IT IF MARKED
TRNE TBITS2,STRING
JRST NOWSTR
PUSH P,$VAL(PNT2)
JRST NOWLUP
NOWSTR: PUSH SP,$PNAME(PNT2)
PUSH SP,$PNAME+1(PNT2)
JRST NOWLUP
NA: HLRZ TEMP,$ADR(PNT) ;Get the address of the procedure from its
;;#GW#2! 5-11-72 DCS (4-4) SEE JUST ABOVE
JUMPL C,NS
PUSHJ P,(TEMP) ; Semblk, and call it for its value
;;#GW#! SEE JUST ABOVE
MOVEM 1,SCNVAL ;Store resultant value where CONINS will expect
TRNN TBITS,STRING ; it, along with the desired type bits from
JRST NS ; the procedure's type.
HRRZ TEMP,-1(SP) ;Align Strings to full-word boundary by
JUMPE TEMP,NLS ; concatenating 0 (if non-null)
PUSH SP,[1]
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
SOS -1(SP) ; then remove the extra character from the end
NLS: POP SP,PNAME+1
POP SP,PNAME
NS: EXCH SP,STPSAV ;PUT OLD STACKS BACK
MOVSS POVTAB+6
ANDI TBITS,-1≠<PROCED!FORWRD!INPROG>
TLO TBITS,CNST
MOVEM TBITS,BITS
PUSHJ P,CONINS
POP P,FTRPRM ;Back the Qstack up to value at start of call
JRST MRKDN ;This just records the result
;;# #
NC:
GLOC <
TLZN SBITS,LPFREE ;A MESSAGE PROCEDURE ??
JRST CAL01 ;NO
MOVEM SBITS,$SBITS(PNT)
HRROI B,$PNAME+1(PNT) ;PRINT NAME.
POP B,PNAME+1
POP B,PNAME ;AND READY TO
PUSHJ P,STRINS ;MAKE A CONSTANT.
PUSHJ P,GETAD ;GET BITS.
GENMOV (STACK,0) ;PISS ON IT.
SOS SDEPTH
SOS SDEPTH ;SINCE TYPPRO WILL ADD 2 TO SDEPTH
MOVEI TBITS2,STRING ;CROCK -- THIS IS THE TYPE OF MESS.
;#IK#! 7-5-72 RHT PREVENT DL FLD OF SBITS FROM CAUSING MUCH BAD DISPLAY LOADING
MOVEI SBITS2,0 ;RENDER SBITS2 HARMLESS (FOR FUTURE EXCHIN &STACK)
JRST MRKCAL ;AND FINISH OUT
CAL01:
>;GLOC
PUSHJ P,STORIX ;INTERNALS.AND EXTERNALS ARE NOW STORED.
TRNE TBITS,FORTRAN ;IF FORTRAN CALL
JRST FTRCAL ;GO ISSUE IT.
MOVEI D,1 ;PREPARE TO STORE R1
;;#TO# ! (2-2) RHT 10-27-74 (USED TO BE INTEGR+FLOTNG)
TRNE TBITS,SNGTYP ;DEFINED IN SAIL/13
PUSHJ P,STORZ ;DO IT IF TYPED ARITH PROC.
TLNN TBITS,BILTIN ;UNLESS BUILTIN PROC.
PUSHJ P,ALLSTO ;STORE THE REST.
DPUSHJ:
;; BY JRL 9-20-72 MAKE SURE PROCEDURE FORMALS CAN BE ACCESSED
GENMOV (ACCESS,0) ;MAKE SURE WE HAVE ACCESS
;; BY JRL
MOVE A,[PUSHJ RP,NOUSAC] ;PUSHJ PDP,ROUTINE.
TLNE FF,LPPROG ;A FOREACH IN PROGRESS AND
TLNN TBITS,MPBIND ;A MATCHING PROCEDURE?
PUSHJ P,EMITER
MVCAL: MOVOPS ;PROC SEMANTICS TO SECOND GROUP.
;BUG TRAP
SKIPN B,-1(P) ;SAVED FRTPRM POINTER.
ERR <DRYROT AT DPUSHJ>
QQQLRX: QTAKE (FTRPRM) ;POP OFF A GOODY
JRST LLQRLX
PUSH P,B
MOVE PNT,A
PUSHJ P,REMOP ;REMOP IT
POP P,B
JRST QQQLRX ;GET ALL OF THEM
LLQRLX:
MOVEI D,1 ;IF ARITH TYPE, RESULTS IN R1
JRST MRKCAL ;FINISH OUT, MARK RESULT
;;#HT# 6-14-72 DCS (1-2) SAVE ALL ACS, ALSO RF, WHEN FORTRAN SUBROUTINE
FTRCAL: TRNN TBITS2,ALTYPS≠(FORTRAN!PROCED);TYPED PROCEDURE?
JRST [PUSHJ P,ALLSTO
HRLI C,RF ;NO, STORE ALL ACS, SAVE F
EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>)
JRST CALFTR]
;;RW#HT# (1-2)
MOVEI D,0 ;ASSURE R0 FREE
PUSHJ P,STORZ
MOVEI D,1 ;AND R1
PUSHJ P,STORZ
CALFTR:
;;%DT% JFR 8-22-76
SKIPE TEMP,ASWITCH
TRNN TEMP,ASWF10
JRST CALF.1 ;NOT FORTRAN-10
SKIPN B,-1(P) ;FTRPRM PTR
ERR <DRYROT -- FTRCAL>;NOT THERE
MOVEI C,0 ;COUNT PARAMS
CALF.2: QTAKE (FTRPRM)
JRST .+2
AOJA C,CALF.2
PUSH P,C ;SAVE # PARAMS
HRLI C,RSP
EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>) ;NEED TO SAVE SP
AOS ADEPTH
MOVE C,PCNT
ADDI C,4
MOVSI C,(C)
EMIT (<MOVEI RSP,NOUSAC!USADDR>) ;MOVEI 16,.+4
EMIT (<PUSHJ RP,NOUSAC>) ;PUSHJ P,ROUTINE
MOVE C,(P) ;# PARAMS
ADD C,PCNT
ADDI C,2
MOVSI C,(C)
EMIT (<JRST NOUSAC!USADDR>) ;JRST AROUND ADDRESS BLOCK
POP P,A ;# PARAMS
MOVNI A,(A)
MOVSI A,(A)
PUSHJ P,CODOUT ;-N,,0
JRST CALF.3
CALF.1: EMIT (<JSA 16,NOUSAC>) ;JSA 16,ROUTINE
CALF.3:
;;%DT% ↑
MOVOPS ;SEMANTICS OF PROC TO 2D GROUP
; ***** BUG TRAP
SKIPN B,-1(P) ;FTRPRM POINTER
ERR <DRYROT -- FTRCAL> ;WASN'T A POINTER
ARGLUP: QTAKE (FTRPRM) ;GET NEXT ADCON DESCRIPTOR
JRST LLLQRX ; DONE WITH ADCONS
PUSH P,B ;SAVE UPDATED POINTER
JUMPL A,ARGFIX ;MOVEI,HRLI,MOVEM WAS DONE, FIX IT UP
PUSH P,A ;SAVE ADCON POINTER
HLRZ PNT,%TLINK(A) ;SEMANTICS OF AD BEING CONNED
HLLZ A,$ADR(A) ;TYPE BITS, ALREADY IN AC FIELD POS
PUSHJ P,GETAD ;GET DESCRIPTION
;;%DT%
SKIPE TEMP,ASWITCH
TRNN TEMP,ASWF10
TLO A,(<JUMP>) ;F40 ONLY
TRO A,NOUSAC ;BOTH
;;%DT% ↑
PUSHJ P,EMITER ;JUMP TYP,ADDR
PUSHJ P,REMOP ;GET RID OF IT
POP P,A ;GET POINTER BACK
HRRZ LPSA,A ;ptr to SEMANTICS OF ADCON
PUSHJ P,URGADR ;REMOVE FROM ADRTAB
FREBLK ;RETURN ADCON BLOCK TO FREE STORAGE
POP P,B ;UPDATED STACK PTR
JRST ARGLUP ;GET ALL OF THEM
ARGFIX:
;;%DT%
MOVEI PNT,(A) ;ADDR OF SEMBLK OF CORE TEMP FOR ADDRESS
TLC A,400020 ;REMOVE FLAG, INSERT @
HRRI A,NOUSAC
PUSHJ P,EMITER ;BITS,@TEMP
PUSHJ P,REMOP ;NO LONGER NEED TEMP
POP P,B ;UPDATED QSTACK PTR
;;%DT% ↑
JRST ARGLUP ;RETURN
LLLQRX: MOVEI D,0 ;IF TYPED, RESULT IN 0
MRKCAL:
HLRZ TEMP,(P) ;NUMBER OF SDEPTH ADJUST WORDS
SUB TEMP,SDEPTH ;ADJUST
MOVNM TEMP,SDEPTH
HRRZ TEMP,(P) ;SIMILAR ADEPTH STUFF
SUB TEMP,ADEPTH
MOVNM TEMP,ADEPTH
POP P,TEMP ;TOSS OUT
POP P,FTRPRM ;RESTORE OLD QSTACK PTR
SETZM PNT
TLNE FF,LPPROG ;A FOREACH IN PROGRESS?
TLNN TBITS2,MPBIND ;THIS A MATCHING PROCEDURE CALL?
JRST ISTYPD ;NO
MOVE TEMP,%MPRO ;MESSAGE PROCEDURE TOKEN
;; #QG# TOKEN BEING PLACED IN WRONG LOC WHEN NO PARAMS
MOVE PNT,PNT2 ;TO BE REPLACED IN PARSE STACK
HLRZ PNT2,%TLINK(PNT) ;SECOND PROCEDURE BLOCK
MOVE PNT2,$NPRMS(PNT2) ;ANY PARAMETERS
CAMN PNT2,[XWD 1,0]
JRST [MOVEM TEMP,PARRIG+1 ;NO PARAMETERS WAS AN ISUCL1
JRST MRKDN]
;; #QG#
MOVEM TEMP,PARRIG ;TELL THE PARSER
JRST MRKDN ;FINI
ISTYPD:
REC <
TRNE TBITS2,PNTVAR ;A POINTER PROCEDURE
TRNE TBITS2,ITEM!ITMVAR ;THESE ARE DIFFERENT
JRST NOTPPP ;NOPE
HLRZ TEMP,$ACNO(PNT2) ;REMEMBER CLASS ID FOR MARK
MOVEM TEMP,RCLASS ;NEXT MARK WILL DO THIS
NOTPPP:
>;REC
;;%DT%
SKIPE TEMP,ASWITCH
;;#XQ# ! JFR 10-21-76 TEST FOR FROTRAN PROC
TRNE TBITS2,FORTRAN
TRNN TEMP,ASWF10
JRST NF10.1
MOVSI C,RSP
EMIT (<POP RP,NOUSAC!USADDR!NORLC>)
SOS ADEPTH
NF10.1:
;;%DT% ↑
;;#HT# 6-14-72 DCS (2-2) RESTORE SAVED RF REGISTER
TRNE TBITS2,ALTYPS≠(FORTRAN!PROCED) ;TYPED PROC?
JRST TYPRC ;YES
TRNN TBITS2,FORTRAN ;NO, FORTRAN PROCEDURE?
JRST MRKDN ;NO, QUIT
HRLI C,RF ;YES, UNTYPED F4, RESTORE RF
EMIT (<POP RP,NOUSAC!USADDR!NORLC>)
JRST MRKDN
;;#HT# (2-2)
TYPRC: GENMOV (MARK,EXCHIN) ;TEMP INDICATES TYPE OF PROCEDURE
MOVEI TEMP,2 ;IF A STRING PROC, INCREASE
;;#HS# JRL 6-14-72 STRING ITEMVAR PROC. IS NOT A STRING PROC.
TRNE TBITS,ITMVAR!ITEM;STRING ITEMVAR PROC. NOT REALLY STRING
JRST MRKDN
;;#HS#
TRNE TBITS,STRING ; STRING STACK DEPTH
ADDM TEMP,SDEPTH
MRKDN: MOVEM PNT,GENRIG ;ONE OF THESE
MOVEM PNT,GENRIG+1 ;WILL COVER IT
POPJ P,
SUBTTL Return Statement
COMMENT ⊗RESULT -- Return (with or without value) from Procedure⊗
DSCR RESULTS, RESLT1
PRO RESULT RESLT1
DES
at RT0: SG ; drarrow S ; EXEC RESLT1 ¬S9
EE2: RETURN ( @E ) drarrow S EXEC RESULTS SCAN ¬S9
⊗
; SETUP PROCEDURE FOR BOTH KINDS OF RETURNS
RETSET: MOVE PNT2,TPROC ;CAN ONLY RETURN FROM INNERMOST PROC
PUSHJ P,GETAD2 ;SEMANTICS OF IT
TLNE TBITS2,MPBIND ;MATCHING PROCS ARE NO-NO'S
ERR <RETURN NOT VALID WITHIN MATCHING PROC.>,1
MOVSI TEMP,RTNDON ;MARK RETURN DONE THIS PROC
IORM TEMP,$SBITS(PNT2) ;IN SEMBLK
EXCH TEMP,(P) ;GEQ 0 IN TOP OF STACK, RETN TO TEMP
JRST (TEMP) ;RETURN
↑RESLT1: PUSHJ P,RETSET ;GET SEMANTICS OF THIS PROC TO 2D GROUP
TRNE TBITS2,ALTYPS≠PROCED ;CANNOT BE TYPED
ERR <TYPED PROCEDURE MUST RETURN A VALUE>
JRST JMPOU1 ;GENERATE THE ARRAY RELEASES AND EXIT JUMP
↑RESULTS:PUSHJ P,RETSET
TRNN TBITS2,ALTYPS≠PROCED ;THIS MUST BE TYPED
ERR <UNTYPED PROCEDURE MUST NOT RETURN A VALUE>,1
;;#HQ#! 6-13-72 DCS ITEMVARS ARE ITEMVARS, NOT THEIR DATUMS!!!!!!!
TRNN TBITS2,ITEM!ITMVAR ;PRECLUDE DATUMS
TRNN TBITS2,STRING ;STRING VALUE RETURNED?
JRST ARRET ; NO, ARITHMETIC VALUE
STRRET: LEFT PNT2,%TLINK,LPSERR ; LPSA ptr to 2D PROCEDURE BLOCK
HRRZ A,$NPRMS(LPSA) ;#PARAMS(STRING)
GETSEM (1) ;GET SEMANTICS OF RESULT
TLNN TBITS2,RECURS ;IF NOT RECURSIVE PROCEDURE
TLNE SBITS,STTEMP ; AND NOT A TEMP RESULT, THEN CAN
JRST RTSTR1 ; DO THE SUB HERE, ELSE JUST STACK
TRNE TBITS,STRING ;IF RESULT IS STRING VALUE FORMAL,
TLNN TBITS,VALUE ; AND IS FIRST STRING PARAM,
JRST NOTEZY ; CAN REPLACE SUB/PUSH BY DIFFERENT SUB
HRRZ TEMP,$NPRMS(LPSA) ;# STRING WORDS
SUBI TEMP,1 ;-1 TO MATCH HOPEFUL CANDIDATE
CAME TEMP,$ADR(PNT) ;THIS THE FIRST STRING PARAM?
JRST NOTEZY ; NO
SUBI A,2 ;REMOVE ONE FEWER STRINGS (LEAVE ANSWER)
PUSHJ P,MARKME ;NOW A TEMP STRING-TYPE RESULT
MOVEM PNT,GENLEF+1 ;WILL BE PICKED UP LATER
NOTEZY: JUMPE A,RTSET ;IF NOTHING TO SUBTRACT, DON'T DO IT
MOVN TEMP,A ;UPDATE SDEPTH TO REFLECT THE COMING SUB
ADDM TEMP,SDEPTH ; SO THAT REFERENCES TO PARAMS ARE RIGHT
;;%DN% JFR 7-2-76
HRLI C,(TEMP)
PUSHJ P,ESPADJ
;; HRLS A ; IN SUBSEQUENT STACKING OPERATION
;; PUSHJ P,CREINT ;FOR SUB
;; EMIT <SUB RSP,NOUSAC> ;SUB RSP,[XWD #,#]
;; PUSHJ P,REMOP ;REMOVE CONSTANT FROM USE
;;%DN% ↑
RTSET: SETOM (P) ;<0 IN TOP OF STACK, MARK THIS CASE
RTSTRG: GETSEM (1) ;SEMANTICS OF RESULT
RTSTR1: MOVEI B,STRING
GENMOV (STACK,INSIST) ;MAKE SURE RESULT IS STACKED
SETZM SDEPTH ;DON'T RECORD EFFECTS OF THIS PUSH
JRST JMPOU1 ;RETURN
ARRET: GETSEM (1) ;ARG.
MOVEI D,1 ;RESULTS TO AC 1
HRRZ B,TBITS2 ;TYPE CONVERSION IF NECESSARY
;; #JT# BY JRL 10-21-72 COPY SET TO BE RETURNED
TRNN TBITS,ITMVAR
TRNN TBITS,SET
JRST ARRET2
PUSH P,PNT
GENMOV (STACK,INSIST)
MOVEI A,0
PUSHJ P,CREINT
GENMOV (STACK,GETD)
LPCALL (CATLST)
MOVNI A,2
ADDM A,ADEPTH
HRLI C,1
EMIT <POP RP,NOUSAC!USADDR!NORLC>
POP P,PNT
PUSHJ P,GETAD
JRST ARRET3
;; #JT#
ARRET2: GENMOV (GET,INSIST!SPAC!POSIT) ;LOAD THE AC
ARRET3: PUSHJ P,REMOP
JMPOUT: PUSHJ P,CLEARA ;FORGET ABOUT AC 1
JMPOU1: EXCHOP ;GET PROC SEMANTICS BACK FROM HIDING
RETJMP: PUSHJ P,GOSTO ;DUMP EVERYTHING, BUT REMEMBER WHERE
MOVE B,LEVEL ;CURRENT LEVEL
SUBI B,1 ;DO NOT ENCOUNTER PROCEDURE
PUSH P,PNT
PUSHJ P,TRAGO ;GUARANTEE ACCESS
POP P,PNT ;THE WORK IS DONE.
MOVE A,[JRST NOUSAC+USADDR] ;THE JUMP OUT
HRR C,PCNT ;PUT CURRENT IN CHAIN
POP P,TEMP ;IF <0, NON-REC, NON-TEMP STRING RESULT
JUMPL TEMP,OTHJMP ; JUMP PAST SUB/PUSH PAIR IN EXIT CODE
HRL C,$ACNO(PNT) ;THIS IS WHERE PROC. RET. FIXUP IS STORED.
HRRM C,$ACNO(PNT) ;CHAIN THE FIXUP.
JRST EMITER ;EMIT JUMP
OTHJMP: HLL C,$ADR(PNT) ;OTHER JUMP ADDR
HRLM C,$ADR(PNT) ;CHAIN
JRST EMITER ;DO IT
COMMENT ⊗DFVPV -- exec for default param values ⊗
ZERODATA();
PBITTS: 0 ;SAVE PARAM BITS HERE
ENDDATA
↑DFVPV0: MOVE A,BITS ;
MOVEM A,PBITTS ;SAVE THE BITS
POPJ P,
↑DFVPV: MOVE PNT,VARB ;THE MOST RECENT FORMAL ON VARB
DFV.01: PUSHJ P,GETAD ;RING
TLNE TBITS,FORMAL ;
JRST GOTVCT
HRRZ PNT,%RVARB(PNT) ;
JUMPN PNT,DFV.01 ;
ERR <DRYROT IN DFVPV, CAN CONTINUE>,1;
JRST DFV.2 ;
GOTVCT: TLNE TBITS,REFRNC ;
ERR <DEFAULT VALUES FOR REF PARAMS IS A VERY BAD IDEA>,1
MOVE PNT2,GENLEF+1 ;THE VALUE
HRRM PNT2,$VAL2(PNT) ;
DFV.2: MOVE A,PBITTS ;PUT BITS BACK
MOVEM A,BITS
POPJ P,
; CLNSET
↑CLNSET:
MOVE PNT,TTOP ;CURRENT BLOCK
HLRZ PNT2,%TLINK(PNT) ;SECOND SEMBLK
JUMPN PNT2,CLNS.1 ;HAVE ONE
GETBLK ;GET ONE
HRLM LPSA,%TLINK(PNT) ;SAVE IT
HRRZ PNT2,LPSA ;
CLNS.1: MOVE A,GENLEF+1 ;PROC SEMBLK
HLRZ B,%TLINK(A) ;SECOND BLOCK
MOVSI C,1 ;STACK DISPLS FOR 0 PARS
CAME C,$NPRMS(B) ;BETTER HAVE NO PARAMS
ERR <CANNOT USE A PROC WITH PARAMS FOR CLEANUP>,1
QPUSH (<$ACNO(PNT2)>) ;REMEMBER
MOVEI A,SET ;SO GO TO SOLVER WORKS
ORM A,$VAL(PNT) ;
POPJ P,
DSCR Execs for PRINT and CPRINT statements.
The PRINT and CPRINT statements allow an arbitrary number
of expressions to be formatting according to expression and printed
out to the teletype or other device. Each expression is converted
to a string by a formatting function (either the standard one or one
supplied by the user) then is printed out to the teletype, file, both,
or to a user-specified function which can do anything.
The expected syntax is either
PRINT(e1,e2, ... , en)
or
CPRINT(chan,e1,e2, ... , en)
The PRINT statement prints out to the Teletype or whatever is specified
by the SETPRINT statement. The CPRINT statement goes to the channel
specified by the first integer argument. Both of these constructions
occur as statements, and both are parsed.
The EXEC functions here (1) initialize the printing by pushing
the channel number for CPRINT or -1 for PRINT onto the stack, done
by STRTPT for PRINT or STCTPT for CPRINT; (2) printing out each argument
by a call on the appropriate runtime, using the syntactic type of
the expression as a key to which function is used; (3) closing off
the PRINT or CPRINT statement by removing the channel argument, which
remains on the stack during the entire operation. Note that the
calling sequence is therefore divergent from the classical SAIL sequence.
Currently, only scalars of each type (INTEGER, REAL, RECORD!POINTER)
are allowed. Adding arrays is a possible extension.
⊗
;start the PRINT statement
↑STRTPT:
SETO A, ;USE -1
PUSHJ P,CREINT ;AS A CHANNEL TO INDICATE TELETYPE
STRTP1: SETZB C,D
EMIT (<PUSH RP,NOUSAC>)
;;#VW# (1 OF 2) STACK NOT ADJUSTED FOR PRINT RLS 12-6-75
AOS ADEPTH ;RECORD CHANGE OF STACK
POPJ P,
;start the CPRINT statement
↑STCPRT:
GETSEM (1) ;CHANNEL ARGUMENT
GENMOV (CONV,INSIST,INTEGR) ;MAKE IT INTEGER
JRST STRTP1 ;AND USE THIS AS THE CHANNEL
;make subroutine call to appropriate function
↑DOPRT:
GETSEM (1)
TLNE TBITS,SBSCRP ;ARRAY?
ERR <PRINT not defined for arrays>,1
SETZ TEMP, ;ASSUME ERROR
TRNN TBITS,ITEM!ITMVAR ;SOME ITEM EXPRESSION
JRST NOTITM
MOVEI TEMP,.$PITM
JRST DOPRT1
NOTITM:
TRNE TBITS,SET
TRNN TBITS,LSTBIT ;IS IT A LIST SOMEHOW?
JRST NOTLST ;NO
MOVEI TEMP,.$PLST ;YES
JRST DOPRT1
NOTLST:
TRNE TBITS,INTEGR ;USE CVS(X) FOR INTEGER
MOVEI TEMP,.$PINT
TRNE TBITS,PNTVAR
MOVEI TEMP,.$PREC
TRNE TBITS,STRING ;JUST PRINT A STRING
MOVEI TEMP,.$PSTR
TRNE TBITS,FLOTNG ;CVG(X) FOR REAL ARGUMENT
MOVEI TEMP,.$PREL
TRNE TBITS,SET ;SETS GET PRINTED {IT, ...}
MOVEI TEMP,.$PSET
DOPRT1: SKIPN TEMP ;A LEGAL PRINT ARGUMENT?
ERR <Can't PRINT this syntactic type>,1
;HERE TO SIMULATE PARSING OF A PROCEDURE CALL FOR PRINT,
;PROCEDURE DESCRIPTOR IS IN TEMP
PRTCAL: PUSH P,GENLEF+1 ;SAVE ARGUMENT
MOVEM TEMP,GENLEF+1 ;PROCEDURE TO CALL
PUSHJ P,RDYCL1 ;PREPARE
MOVEW <GENLEF+2>,<GENRIG+1>
POP P,GENLEF+1
PUSHJ P,CALARG ;NOW SEND ARGUMENT
JRST ISUCAL ;AND FINALLY THE CALL
;finish up a PRINT or CPRINT sequence
↑ENDPRT:
;;%DN% JFR 8-17-76 POSSIBLY USE ADJSP
SOS ADEPTH
HRLI C,-1 ;REMOVE 1 EL
JRST EPADJ ;FROM P STACK
;; MOVE A,X11
;; PUSHJ P,CREINT ;CREATE AN INTEGER XWD 1,1
;; SETZB C,D
;; EMIT (<SUB RP,NOUSAC>) ;NOW ADJUST USER'S STACK AFTER PRINT
;;#VX# STACK NOT ADJUSTED FOR PRINT RLS 12-6-75
;; SOS ADEPTH ;AND MARK THAT STACK RESET
;; POPJ P,
;;%DN% ↑
BEND PROCED